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

Argl... Also doch nicht... Mir fehlte zwar der Sinn für Artikel-Zeilen ohne Merkmal und ich dachte auch, ich hätte das so verstanden, daß die auch wegfallen könnten... Aber dann...

Ist aber simpel: Vor der inneren Schleife, die die Zeile durchläuft, setzt man einfach einen Boolean, der beim Kopieren umgedreht wird. Ist am Ende der Schleife der Merker noch im Original, muß man, da keine Mermale vorhanden waren, wenigstens die Artikelnummer kopieren.

Code:

    y2 = 1

    t1 = Now()
    For y1 = 2 To s1.Cells(65536, 1).End(xlUp).Row
        c = True
        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
                c = False

            End If
        Next x1
        If (c) Then
            y2 = y2 + 1
            s2.Cells(y2, 1).Value = s1.Cells(y1, 1).Value
        End If
    Next y1

Ich hab mal die 50 Beispiel-Zeilen bis Zeile 4300 kopiert. Bei 254 Spalten (links Artikelnr., rechts eine leere Spalte) und 4.300 Zeilen = 1.092.200 Läufe braucht das Ding 15 Sekunden, um 65112 Zeilen auf dem 2. Blatt zu erzeugen. Mehr krieg ich mit x2000 ja leider nicht hin... Die Zeit ist auch zu kurz, um Auswirkungen von Optimierungen (ich hab nach wie vor das trim$() im Auge) wirklich spürbar messen zu können.

Gruß, Michael

 

Hallo Michael,

Deinen Code habe ich mal, mit kleinen Änderungen an 30000Zeilen ausprobiert und er braucht ca. 10min. Der Code von Achim braucht für die gleiche Konstellation 2min, meiner steigt beim Löschen aus, d.h. er braucht zu lange.


Gruß

Edgar

 

Hm, ok, das ist lahm...

Und wenn Du

Code:

If (Trim$(s1.Cells(y1, x1).Value) <> "") Then

mal gegen

Code:

If (not isempty(s1.Cells(y1, x1))) Then

austauschst? Ist's dann merklich schneller?

Gruß, Michael

 

Hallo Michael und Edgar,
sry wenn ich mir Eure Codes im Moment nicht näher anschaue bzw. sie ausprobiere.
Habe gerade ein eklatantes Zeitdefizit.
Aber ich finde es interessant mit zu lesen. ;O)
Wenigstens habe ich jetzt das "If Not IsEmpty" auch in der inneren Schleife übernommen.
So wird wenigstens beide Male auf gleiche Art geprüft.

Bei der Gelegenheit mal ne Frage:
Reiners Datei auf 60.000 Zeilen erweitert ergibt bei mir eine Speichergröße von 261.594 KB.
Diese Datei nach dem Makrodurchlauf, also über 900.000 Zeilen in 3 Spalten in Blatt 2 zusätzlich, ergibt bei mir eine Speichergröße von 277.549 KB.
Ich hätte einen größeren Unterschied erwartet.



@ Reiner

Da ich nicht weiß wie Deine Datei im Detail aussieht (wieviele Blätter hat sie, sind die leer... etc.), habe ich meinen Code jetzt so geändert, dass am Anfang erstmal ein neues Blatt eingefügt wird, auf welches die umgestellten Daten geschrieben werden.
Zusätzlich wird bei erreichen der maximalen Zeilenanzahl erneut ein neues Blatt eingefügt, und die umgestellten Daten werden dort weiter geschrieben.
Dies würde sich bei Bedarf so oft wiederholen wie nötig.
Die Zeilenbegrenzung ist also kein Problem mehr, nur könnte es für Dich jetzt zum Problem beim einlesen der Daten werden, wenn diese auf mehreren Blättern verteilt sind.

Dazu bitte mal äußern.

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.Add(after:=Worksheets(Worksheets.Count))
    
    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 Not IsEmpty(.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
                        Set wksZiel = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                        wksZiel.Cells(1, 1) = "Artikelnummer"
                        wksZiel.Cells(1, 2) = "Merkmal"
                        wksZiel.Cells(1, 3) = "Wert"
                        loZeile = 2
                    End If
                Next intCounter
            End If
       Next locounter
    End With
End Sub

 

Argl, da ist noch ein anderer klitzekleiner Schreibfehler drin!

Code:

For x1 = 2 To s1.Cells(1, 256).End(xlToLeft).Column

prüft ja jede Zeile so weit bis rechts, wie es Überschriften (Zeile 1) gibt. Das war so nicht geplant. Jede Zeile sollte nur bis zum jeweils letzten Wert in der aktuellen Zeile durchlaufen werden:

Code:

For x1 = 2 To s1.Cells(y1, 256).End(xlToLeft).Column

Gruß, Michael