Office: Daten Horizontal nach Vertikal ändern aber aufgeschlüsselt

Hallo,

ich verzweifel an der Umstellung der Daten die ich habe.

Ausgangssituation ist folgende:

Artnr Merkmal Merkmalwert Merkmal Merkmalwert Merkmal Merkmalwert
100 Farbe rot Hoch 111 Breit 5555
200 Farbe blau Hoch 222 Breit 6666
300 Farbe grün Hoch 333 Breit 7777
400 Farbe gelb Hoch 444 Breit 8888

Ein Artikel mit mehreren Merkmalen

Für einen Datenimport benötige ich aber dieses Format:

Halt so oft den gleichen Artikel in jeweils einer Zeile wie er Merkmale hat.

Es können auch Artikel auftauchen die nur ein Merkmal oder keins haben

Artnr merkmal merkmalwert
100 Farbe rot
100 Hoch 111
100 Breit 5555
200 Farbe blau
200 Hoch 222
200 Breit 6666
300 Farbe grün
300 Hoch 7777
300 Breit 333
400 Farbe gelb
400 Hoch 444
400 Breit 8888

Ich bin für jede Hilfe dankbar.

 

Hallo reiner,

ich habe in Deiner Beispielmappe im Modul von "Tabelle1" ein Makro eingefügt (siehe Anhang).
Ich denke das macht was Du möchtest.

Noch muss das Makro manuell ausgelöst werden, aber das kannst Du ja noch mit einem Ereignis oder einer Schaltfläche verbinden.

Eine Frage noch:
Wenn ein Artikel kein Merkmal hat, soll er in der Liste bleiben, oder gelöscht werden?
Das Löschen müsste dann noch eingebaut werden.


Ich hoffe geholfen zu haben.

 

Danke

Hallo,

ich werde es am Wochenende sofort testen.

Vielen Dank für die Hilfe.

 

Hallo reiner,

ich habe noch eine Prüfung eingefügt, ob das letzte Artikelmerkmal pro Zeile auch einen Artikelwert zugeordnet hat.
Falls nicht, würde alles verschoben umkopiert.
Hatte ich vergessen.

Code:

If intLetzte Mod 2 = 0 Then intLetzte = intLetzte + 1

 

Fast Perfekt wenn da nicht noch....

Hi,
vielen vielen Dank !!!!

aber ich versuche das noch weiter auszureizen.

Wenn sich jemand fragt wofür es ist: Wie wandel ich eine BMEcat Datei (.xml) in eine für andere Systeme verarbeitbare .csv Datei um.
Das Hauptproblem bei solchen Daten sind die unzähligen Merkmale die ein Artikel haben kann.

Um jetzt noch den letzten Luxus evtl zu haben:

Die Spalten die rot markiert sind, sind in der Orginaldatei nicht vorhanden.
Der Wert der in dieser Spalte steht, ergibt sich aus der Überschrift des Merkmalwertes.

Also müßte am Anfang vor jedem Merkmalwert eine Spalte eingefügt werden, mit dem Wert ausgefüllt werden der als Überschrift über den Merkmalwerten steht.

Ich habe eine Musterdatei angehangen in denen man den Umfang erkennen kann. Es können dutzenden Merkmale vorhanden sein.

Auch wenn ein Artikel kein Merkmal hat, muß er in der Liste bleiben.

Artnr Merkmal Merkmalwert Merkmal Merkmalwert Merkmal Merkmalwert
100 Farbe rot Hoch 111 Breit 5555
200 Farbe blau Hoch 222 Breit 6666
300 Farbe grün Hoch 333 Breit 7777
400 Farbe gelb Hoch 444 Breit 8888

Artnr merkmal merkmalwert
100 Farbe rot
100 Hoch 111
100 Breit 5555
200 Farbe blau
200 Hoch 222
200 Breit 6666
300 Farbe grün
300 Hoch 7777
300 Breit 333
400 Farbe gelb
400 Hoch 444
400 Breit 8888

Ich bin für jede Hilfe dankbar.

 

Re: Fast Perfekt wenn da nicht noch....

Hallo Reiner,
also wenn ich Dich richtig verstehe, hast Du als Ausgangsmaterial eine Tabelle mit folgendem Schema:

Artnr..Farbe..Hoch..Breit..Lang
100....rot......111....555...911
200....blau....222............233
300..............333....777
400....gelb.............888...546

Ich habe folgenden Code hinzugefügt:

Code:

' letzte nicht-leere Zelle in Zeile 1 (Überschriften)
intLetzte = IIf(IsEmpty(.Cells(1, .Columns.Count)), .Cells(1, .Columns.Count).End(xlToLeft).Column, .Columns.Count)

' Schleife über alle benutzen Zeilen um Spalten für die Merkmale einzufügen
For loCounter = intLetzte To 2 Step -1
    .Columns(loCounter).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    .Range(.Cells(2, loCounter), .Cells(loLetzte, loCounter)).Value = .Cells(1, loCounter + 1).Value
Next loCounter

Damit werden die von Dir gewünschten Spalten eingefügt und mit den Überschriften ausgefüllt.

Am Ende habe ich noch folgendes hinzugefügt:

Code:

.Cells(1, 2).Value = "Merkmal"
.Cells(1, 3).Value = "Wert"
Union(.Columns(1), .Columns(2), .Columns(3)).EntireColumn.AutoFit

Dies schreibt neue Überschriften für die zweite und dritte Spalte, und stellt die ersten drei Spalten auf die optimale Breite ein.
Keine Ahnung ob Du das brauchst, dachte es könnte hilfreich sein.
Diese drei Zeilen kannst Du ohne Probleme weglassen.


Zwei Fragen noch:

1.
Benötigst Du, wie in deiner Beispielmappe, auch Farben oder sonstige Formatierungen? Dann sage was, wie, wo und ich baue es noch ein.

2.
Momentan schreibt mein Code für jeden Artikel und jedes Merkmal eine Zeile, egal ob das Merkmal auch einen Wert zugeordnet hat.
Ergo hat jeder Artikel die gleiche Anzahl von Zeilen, selbst wenn er nicht einen einzigen Wert hat.

Je nachdem wie und womit Deine Daten später ausgelesen werden, kann dies sinnvoll, ja sogar nötig sein.
Es kann in Deinem Fall aber auch unnötig oder sogar problematisch sein.

Wie brauchst Du das Ergebnis?
So wie jetzt, oder sollen Merkmale ohne Wert ausgelassen werden?
Dann müsste ich das noch ändern.

Meinen aktuellen Code findest Du in der angehängten Mappe.


ich hoffe geholfen zu haben.

 

Hallo Achim,

deine Hilfe ist einfach Perfekt.

Nach ein paar Tests habe ich jetzt den Versuch mit der großen Datei gestartet.

Ok, bei ca. 60.000 Zeilen und ca. 100 Spalten dauert es ein bischen aber ich muß ja nicht dabei sitzen bleiben .

Deine Frage mit den Artikeln die keine Merkmale haben ist berechtigt.

Bei dem Imoport der Daten wird der Merkmalwert angelegt für den Artikel, aber ohne Wert. Unschön wenn man den Artikel aufruft.

Deswegen: Artikelnummern ohne Wert bei den Merkmalen raus !!

Viele Grüße

Reiner

 

Hallo Reiner,

sowas in der Art habe ich mir gedacht.

Also, ich habe folgendes eingebaut:
Hat ein Merkmal keinen Wert, so wird dafür keine neue Zeile eingefügt, sondern das Merkmal wird gelöscht.

Code:

' Schleife durch alle Merkmale wenn mehr als 1 vorhanden ist
Do While intLetzte > 3
    ' Abfrage ob Merkmalwert vorhanden
    If .Cells(loCounter, intLetzte).Value <> "" Then
        ' neue Zeile einfügen
        .Rows(loCounter + 1).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ' Artikelnummer kopieren und in neue Zeile einfügen
        .Cells(loCounter, 1).Copy Destination:=.Cells(loCounter + 1, 1)
        ' letztes Artikelmerkmal kopieren und in neue Zeile einfügen
        .Range(.Cells(loCounter, intLetzte - 1), .Cells(loCounter, intLetzte)).Copy _
            Destination:=.Range(.Cells(loCounter + 1, 2), .Cells(loCounter + 1, 3))
        ' letztes Artikelmerkmal löschen
        .Range(.Cells(loCounter, intLetzte - 1), .Cells(loCounter, intLetzte)).ClearContents
    Else
        ' wenn kein Merkmalwert vorhanden, dann Merkmal entfernen
        .Cells(loCounter, intLetzte - 1).ClearContents
    End If
    ' Variable anpassen
    intLetzte = intLetzte - 2
Loop

Beim ersten Merkmal, also in Spalte B, welches ja immer als letztes abgearbeitet wird, wird geprüft ob es einen Wert hat.
Falls ja > bleibt die Zeile
Falls nein, wird zusätzlich noch geprüft ob die Artikelnummer mit der darunter übereinstimmt.
Falls ja > Artikel hat also schon ein Merkmal mit einem Wert, wird die Zeile komplett gelöscht.
Falls nein, hat der Artikel also nicht ein einziges Merkmal mit Wert, dann wird nur das Merkmal gelöscht, die Artikelnummer bleibt aber bestehen.
(wie Du das am 21.09.2011 um 16:19 gewünscht hast).

Code:

' Abfrage ob erstes Merkmal einen Wert zugeordnet bekommen hat
If .Cells(loCounter, 3).Value = "" Then
    ' Abfrage ob Artikel bereits ein Merkmal mit Wert hat
    If .Cells(loCounter, 1).Value = .Cells(loCounter + 1, 1).Value Then
        ' wenn ja, dann Zeile löschen
        .Rows(loCounter).EntireRow.Delete shift:=xlUp
    Else
        ' wenn nein, Merkmal löschen aber Artikelnummer stehen lassen
        .Cells(loCounter, 2).ClearContents
    End If
End If

Wenn ich nichts übersehen habe, sollte es so eigentlich klappen.

Zusätzlich habe ich mit:

Code:

Application.ScreenUpdating = False

die Bildschirmaktualisierung deaktiviert (und am Ende natürlich wieder aktiviert).
Möglicherweise beschleunigt dies den Code ein wenig.
Und falls Du während der Laufzeit einen flackernden Bildschirm hattest, ist dies nun auch weg.

Den kompletten Code gibts wieder im Anhang.


By the way, wie lange in etwa dauert denn bei Dir so ein Durchlauf für 60000 Zeilen mit 100 Spalten?
Macht da eine Fortschrittsanzeige für Dich Sinn?

 

Hallo Achim,

habe das Wochenendes durchgekämpft.
Mit mäßigem Erfolg.
Teile ich die Datei Zeilenmäßig auf klappt es.

Bei 60.000 Zeilen keine Ahnung wie lange der Ablauf dauert, nch ca 10 Stunden habe ich abgebrochen, das ganze mehrfach versucht.

Also währe ein Fortschrittsanzeige hilfreich um zu sehen ob überhaupt etwas passiert. Taskmanager hat fleißig angezeigt das gearbeitet wird.

Im Anhang einmal die ersten 50 Zeilen der großen Datei mit allen Merkmalen

Viele Grüße und nochmal Danke für die Hilfe.

Reiner

 

Hallo Reiner,

ich musste kräftig schlucken als ich das mit den 10h las.
Und nochmal musste ich kräftig schlucken, als ich Deine Datei geöffnet hatte.

Deine Merkmale gehen bis knapp an Spalte 1870 heran.
Und Du hast 60.000 Zeilen.
Das sind 112.200.000 Zellen.

Ich habe aus Deiner Datei mal die Zeilen 8 bis 50 gelöscht, und die Zeit gemessen, die das Makro nur für die ersten 6 Artikelzeilen benötigt.
Auf meinem Rechner sind das 81547 Millisekunden, also etwa 1,33 Minuten.
Damit käme mein Rechner bei Deiner kompletten Datei auf ca. 46 1/4 Jahre. (falls ich mich nicht verrechnet habe)

Du warst also nur ein klein wenig zu ungeduldig... ;O)
*ich schrei mich wech*
(sry, musste sein)


Also, mein bisheriges Konzept können wir getrost über Bord werfen.
Da muss was anderes, viel effektiveres her.

Ich habe auch schon eine Idee, aber jetzt noch erst was anderes zu tun.
Weiß nicht ob ich heute noch Zeit dafür habe.

 

Hallo,

versuche mal das:

5Minuten für 2000Zeilen mit löschen, vielleicht findet jemand noch eine schnellere Löschroutine:

Code:

Option Explicit

Public Sub DatenUmstellen()
   Dim loLetzte As Long
   Dim loSpalte As Long
   Dim loA As Long
   Dim loB As Long
   Dim loC As Long
   Dim myarr As Variant
   Dim myarr2 As Variant
   Dim wks As Worksheet
   Dim rng As Range
   Dim Zelle As Range
   loC = 1
Application.ScreenUpdating = False
   Set wks = Sheets("Tabelle1") 'zu verändernde Tabelle benennen
      With wks
        loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row 'Letzte Zeile in Spalte A
            For loA = 2 To loLetzte
                loSpalte = .Cells(loA, Columns.Count).End(xlToLeft).Column 'Letzte Spalte in der aktuellen Zeile
                Cells(loC, 1) = .Cells(loA, 1)
                Range(Cells(loC, 1), Cells(loC + loSpalte - 2, 1)).FillDown 'Spalte A ausfüllen mit der Nummer
                Set myarr = .Range(.Cells(1, 2), .Cells(1, loSpalte)) 'Merkmalnamen einlesen
                Set myarr2 = .Range(.Cells(loA, 2), .Cells(loA, loSpalte)) 'Merkmalwert einlesen
                Range(Cells(loC, 2), Cells(loC + loSpalte - 2, 2)) = WorksheetFunction.Transpose(myarr) 'Merkmal in Spalte B eintragen
                Range(Cells(loC, 3), Cells(loC + loSpalte - 2, 3)) = WorksheetFunction.Transpose(myarr2) 'Merkmalwert in Spalte C eintragen
                For loB = loC + loSpalte - 2 To loC Step -1
                    If Cells(loB, 3) = "" Then Rows(loB).Delete
                Next
                loC = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Next
    End With
Application.ScreenUpdating = True
End Sub

Nachtrag: Mit 6000 Zeilen etwa 13Minuten
Bei 60000 Zeilen wird wohl das Ganze zusammenbrechen, weil Excel die Datenmenge nicht mehr packt. Zudem besteht die Gefahr, dass das Limit der Zeilenanzahl überschritten wird. Deine 49Zeilen ergeben immerhin 743 umsortieren Zeilen
Ich würde mir nochmal Gedanken machen, ob das sein muß.

Gruß

Edgar

 

Ich hab nur x2000, also Beschränkung auf 65536 Zeilen mit 256 Spalten. Ich bin mir, so als Nachzügler-Quereinsteiger, auch nicht ganz sicher, ob ich die Aufgabenstellung wirklich ganz verstanden habe. Aber mein erster Ansatz wäre mit ein paar weniger VBA-Codezeilen:

Code:

    For y1 = 2 To s1.Cells(65536, 1).End(xlUp).Row
        For x1 = 2 To s1.Cells(1, 256).End(xlToLeft).Column
            If (Trim$(s1.Cells(y1, x1).Value) <> "") Then

                y2 = y2 + 1
                s2.Cells(y2, 1).Value = s1.Cells(y1, 1).Value
                s2.Cells(y2, 2).Value = s1.Cells(1, x1).Value
                s2.Cells(y2, 3).Value = s1.Cells(y1, x1).Value

            End If
        Next x1
    Next y1

Das Ding durchläuft also "brute force" mäßig die komplette Matrix von links oben bis rechts unten. In jedem Feld wird überprüft, ob ein Wert enthalten ist. Wenn ja, wird die Artikelnummer aus der aktuellen Zeile (Spalte 1), das Merkmal aus der aktuellen Spalte (Zeile 1) und der Wert aus der aktuellen Zelle in das 2. Blatt übertragen.

Wenn aus dem hier:
<TABLE border="1" cellspacing="0" cellpadding="3"><TR><TD width="20" bgcolor="#c0c0c0"> </TD><TD width="100" align="center" bgcolor="#c0c0c0">A</TD><TD width="100" align="center" bgcolor="#c0c0c0">B</TD><TD width="100" align="center" bgcolor="#c0c0c0">C</TD><TD width="100" align="center" bgcolor="#c0c0c0">D</TD><TD width="100" align="center" bgcolor="#c0c0c0">E</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">1</TD><TD bgcolor="#FFFFFF">Artikel</TD><TD bgcolor="#FFFFFF">Farbe</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">Länge</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">2</TD><TD bgcolor="#FFFFFF">123</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">10</TD><TD bgcolor="#FFFFFF">20</TD><TD bgcolor="#FFFFFF">30</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">3</TD><TD bgcolor="#FFFFFF">234</TD><TD bgcolor="#FFFFFF">grün</TD><TD bgcolor="#FFFFFF">20</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">40</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">4</TD><TD bgcolor="#FFFFFF">345</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">30</TD><TD bgcolor="#FFFFFF">40</TD><TD bgcolor="#FFFFFF">50</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">5</TD><TD bgcolor="#FFFFFF">456</TD><TD bgcolor="#FFFFFF">cyan</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">50</TD><TD bgcolor="#FFFFFF"> </TD></TR><TR><TD align="center" bgcolor="#c0c0c0">6</TD><TD bgcolor="#FFFFFF">567</TD><TD bgcolor="#FFFFFF">magenta</TD><TD bgcolor="#FFFFFF">50</TD><TD bgcolor="#FFFFFF">60</TD><TD bgcolor="#FFFFFF"> </TD></TR><TR><TD align="center" bgcolor="#c0c0c0">7</TD><TD bgcolor="#FFFFFF">678</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">60</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">80</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">8</TD><TD bgcolor="#FFFFFF">789</TD><TD bgcolor="#FFFFFF">grau</TD><TD bgcolor="#FFFFFF">70</TD><TD bgcolor="#FFFFFF">80</TD><TD bgcolor="#FFFFFF">90</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">9</TD><TD bgcolor="#FFFFFF">890</TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF"> </TD><TD bgcolor="#FFFFFF">90</TD><TD bgcolor="#FFFFFF">100</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">10</TD><TD bgcolor="#FFFFFF">901</TD><TD bgcolor="#FFFFFF">schwarz</TD><TD bgcolor="#FFFFFF">90</TD><TD bgcolor="#FFFFFF">100</TD><TD bgcolor="#FFFFFF">110</TD></TR></TABLE>

das hier werden soll:
<TABLE border="1" cellspacing="0" cellpadding="3"><TR><TD width="20" bgcolor="#c0c0c0"> </TD><TD width="100" align="center" bgcolor="#c0c0c0">A</TD><TD width="100" align="center" bgcolor="#c0c0c0">B</TD><TD width="100" align="center" bgcolor="#c0c0c0">C</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">1</TD><TD bgcolor="#FFFFFF">Artikel</TD><TD bgcolor="#FFFFFF">Merkmal</TD><TD bgcolor="#FFFFFF">Wert</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">2</TD><TD bgcolor="#FFFFFF">123</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">10</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">3</TD><TD bgcolor="#FFFFFF">123</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">20</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">4</TD><TD bgcolor="#FFFFFF">123</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">30</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">5</TD><TD bgcolor="#FFFFFF">234</TD><TD bgcolor="#FFFFFF">Farbe</TD><TD bgcolor="#FFFFFF">grün</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">6</TD><TD bgcolor="#FFFFFF">234</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">20</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">7</TD><TD bgcolor="#FFFFFF">234</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">40</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">8</TD><TD bgcolor="#FFFFFF">345</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">30</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">9</TD><TD bgcolor="#FFFFFF">345</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">40</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">10</TD><TD bgcolor="#FFFFFF">345</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">50</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">11</TD><TD bgcolor="#FFFFFF">456</TD><TD bgcolor="#FFFFFF">Farbe</TD><TD bgcolor="#FFFFFF">cyan</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">12</TD><TD bgcolor="#FFFFFF">456</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">50</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">13</TD><TD bgcolor="#FFFFFF">567</TD><TD bgcolor="#FFFFFF">Farbe</TD><TD bgcolor="#FFFFFF">magenta</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">14</TD><TD bgcolor="#FFFFFF">567</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">50</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">15</TD><TD bgcolor="#FFFFFF">567</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">60</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">16</TD><TD bgcolor="#FFFFFF">678</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">60</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">17</TD><TD bgcolor="#FFFFFF">678</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">80</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">18</TD><TD bgcolor="#FFFFFF">789</TD><TD bgcolor="#FFFFFF">Farbe</TD><TD bgcolor="#FFFFFF">grau</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">19</TD><TD bgcolor="#FFFFFF">789</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">70</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">20</TD><TD bgcolor="#FFFFFF">789</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">80</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">21</TD><TD bgcolor="#FFFFFF">789</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">90</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">22</TD><TD bgcolor="#FFFFFF">890</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">90</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">23</TD><TD bgcolor="#FFFFFF">890</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">100</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">24</TD><TD bgcolor="#FFFFFF">901</TD><TD bgcolor="#FFFFFF">Farbe</TD><TD bgcolor="#FFFFFF">schwarz</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">25</TD><TD bgcolor="#FFFFFF">901</TD><TD bgcolor="#FFFFFF">Breite</TD><TD bgcolor="#FFFFFF">90</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">26</TD><TD bgcolor="#FFFFFF">901</TD><TD bgcolor="#FFFFFF">Höhe</TD><TD bgcolor="#FFFFFF">100</TD></TR><TR><TD align="center" bgcolor="#c0c0c0">27</TD><TD bgcolor="#FFFFFF">901</TD><TD bgcolor="#FFFFFF">Länge</TD><TD bgcolor="#FFFFFF">110</TD></TR></TABLE>

Dann müßte im angehängten Beispiel in erster Line die 65536 bzw. 256 angepaßt werden. Vielleicht mag da ja jemand einen Benchmark mit mehr Daten fahren? Man könnte noch etwas Speed rausholen, wenn
- Events abgeschaltet werden
- automatische Neuberechnungen abgeschaltet werden
- Bildschirmaktualisierung abgeschaltet wird
- auf das trim$() verzichtet werden kann
Vor allem vom letzten Punkt würde ich mir noch einiges versprechen. String-Operationen sind eigentlich immer schnarchlangsam...

Gruß, Michael

 

Hallo,

hier mal was, was 30000Zeilen in 2Minuten schafft:

Code:

Option Explicit

Public Sub DatenUmstellen()
   Dim loLetzte As Long
   Dim loSpalte As Long
   Dim loA As Long
   Dim loB As Long
   Dim loC As Long
   Dim loD As Long
   Dim myarr As Variant
   Dim myarr2 As Variant
   Dim wks As Worksheet
   Dim rng As Range
   
   loC = 1
   loD = 1
Application.ScreenUpdating = False
   Set wks = Sheets("Tabelle1") 'zu verändernde Tabelle benennen
      With wks
        loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row 'Letzte Zeile in Spalte A
            For loA = 2 To loLetzte
                loSpalte = .Cells(loA, Columns.Count).End(xlToLeft).Column 'Letzte Spalte in der aktuellen Zeile
                Cells(loC, 1) = .Cells(loA, 1)
                Range(Cells(loC, 1), Cells(loC + loSpalte - 2, 1)).FillDown 'Spalte A ausfüllen mit der Nummer
                Set myarr = .Range(.Cells(1, 2), .Cells(1, loSpalte)) 'Merkmalnamen einlesen
                Set myarr2 = .Range(.Cells(loA, 2), .Cells(loA, loSpalte)) 'Merkmalwert einlesen
                Range(Cells(loC, 2), Cells(loC + loSpalte - 2, 2)) = WorksheetFunction.Transpose(myarr) 'Merkmal in Spalte B eintragen
                Range(Cells(loC, 3), Cells(loC + loSpalte - 2, 3)) = WorksheetFunction.Transpose(myarr2) 'Merkmalwert in Spalte C eintragen
                loD = WorksheetFunction.CountIf(Range(Cells(loC, 3), Cells(loC + loSpalte - 2, 3)), "")
                If loD > 0 Then
                For loB = loC + loSpalte - 2 To loC Step -1
                    If Cells(loB, 3) = "" Then
                        If rng Is Nothing Then
                            Set rng = Rows(loB)
                        Else
                            Set rng = Union(rng, Rows(loB))
                        End If
                    End If
                Next
                If Not rng Is Nothing Then rng.Delete
                Set rng = Nothing
                End If
                loC = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Next
    End With
Application.ScreenUpdating = True
End Sub

@Michael,

ich denke, das grösste Problem sind die 60000Zeilen mit Werten. Da braucht man schon einen sehr leistungsfähigen Rechner, weil das massiv auf die Ressourcen geht. Allein das Laden der Datei dauert bei mir schon eine Weile. Ich werde Deinen Code aber mal testen.

Habe mal mit 30000 Zeilen getestet, dauert 10Min. Problem ist, dass die Zeile 1 ca 1450 Einträge hat. Mal sehen, was da noch zu machen ist.

 

WOW, ich bin begeistert über die ganze Hilfe.

Ich werde es heute Abend sofort testen und Feedback geben.

Viele Grüße an alle.

Reiner

 

@ all
Danke auch von mir für die "Schützenhilfe".


@ Edgar
Deinen ersten Code habe ich getestet.
Da ist irgendwie ein Fehler mit der Artikelnummer drin.
Bin aber nicht so ganz dahinter gestiegen.
Deinen zweiten habe ich noch nicht laufen lassen.


@ Michael
Dein Code scheint prinzipiell zu funktionieren (habe bei Dir auch nix anderes erwartet).


Problem bei beiden (wenn ich nicht ganz daneben liege):
Artikelnummern ganz ohne Merkmalwert fallen unter den Tisch.
Genau das sollen sie aber nicht.



@ Reiner

Weiter unten findest Du einen neuen Vorschlag von mir.
Es wird auch auf ein zweites Blatt kopiert, wie bei den anderen Vorschlägen.
Allerdings werden Artikelnummern ganz ohne Merkmalwert in einer Zeile übernommen. Sie fallen nicht weg.

Zum testen habe ich Deine Datei benutzt, die 49 Artikelzeilen 1225-mal kopiert und immer unten eingefügt.
Damit hatte ich dann 60075 Zeilen.
Bei beiden Testläufen kam mein altersschwacher Rechner auf ca. 6 Minuten.
Ich habe keinerlei Events o.ä. ausgeschaltet, damit könnte man vermutlich noch Zeit gutmachen.

Egal welchen der nun vorgeschlagenen Lösungswege Du nehmen wirst, ich denke im groben wirds passen.
Aber ich sehe da ein ganz anderes Problem:
Die Artikelzeilen aus Deiner Datei haben durchschnittlich 15,163 Merkmalwerte pro Artikel.
Das bedeutet, aus den 60075 Artikelzeilen, wurden auf dem 2. Blatt 910919 Zeilen.
Das Zeilenlimit von Excel ab Version 2007 liegt bei 1048576 Zeilen.
Damit blieben noch 137657 leere Zeilen in Reserve.
Hört sich vielleicht viel an, aber bei 60075 Artikeln wären dies gerade mal 2,29 Merkmalwerte pro Artikel zusätzlich.

Da von uns aber niemand Deine Artikel kennt, und somit auch nicht weiß wieviele Merkmalwerte Deine Artikel im Durchschnitt haben, kannst nur Du uns sagen, ob ein Sprung in ein neues Blatt eingebaut werden sollte, sobald die maximale Zeilenanzahl erreicht ist.
(In meinem Code kommt dann eine Messagebox und der Code wird unterbrochen.)

Ich hoffe ich habe das Problem für alle verständlich geschildert.

Und hier nun mein Vorschlag:

Code:

Option Explicit

Public Sub DatenUmstellen()
    
    Dim wksQuelle As Worksheet
    Dim wksZiel As Worksheet
    
    Dim intLetzte As Integer
    Dim intCounter As Integer
    Dim loLetzte As Long
    Dim loZeile As Long
    Dim locounter As Long
    Dim loLetzteZeile As Long
    
    Set wksQuelle = Worksheets(1)
    Set wksZiel = Worksheets(2)
    
    wksZiel.Cells(1, 1) = "Artikelnummer"
    wksZiel.Cells(1, 2) = "Merkmal"
    wksZiel.Cells(1, 3) = "Wert"
    loZeile = 2
    
    With wksQuelle
        
        loLetzteZeile = .Rows.Count
        
        loLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        For locounter = 2 To loLetzte
            
            intLetzte = IIf(IsEmpty(.Cells(locounter, .Columns.Count)), .Cells(locounter, .Columns.Count).End(xlToLeft).Column, .Columns.Count)
            If intLetzte = 1 Then
                wksZiel.Cells(loZeile, 1) = .Cells(locounter, 1)
                loZeile = loZeile + 1
            Else
                For intCounter = 2 To intLetzte
                    If .Cells(locounter, intCounter) <> "" Then
                        wksZiel.Cells(loZeile, 1) = .Cells(locounter, 1)
                        wksZiel.Cells(loZeile, 2) = .Cells(1, intCounter)
                        wksZiel.Cells(loZeile, 3) = .Cells(locounter, intCounter)
                        loZeile = loZeile + 1
                    End If
                    If loZeile = loLetzteZeile Then
                        MsgBox "Das Zeilenlimit wurde erreicht. Abbruch in Zeile " & locounter
                        Exit Sub
                    End If
                Next intCounter
            End If
       Next locounter
    End With
End Sub