VB Makro hängt sich auf bei großen Datenmengen
#1
Hallo Leute,

ich habe ein kleines Problem mit einem VB Makro.

Vorab zur Problemstellung, welche das Makro lösen soll:

Es existieren Tabellen mit mehreren Datensätzen. Z.B. 10 Spalten auf 2500 Zeilen. Eine Spalte (im folgenden Beispiel die 7. Spalte) enthält einen Zahlenwert.
Sobald dieser Zahlenwert von 1 abweicht soll die entsprechende Zelle den Wert 1 erhalten und danach die Zeile um die Häufigkeit des Wertes darunter kopiert werden.

D.h. z.B. haben wir folgende Tabelle (Zielwert fett markiert):

Wert A - Wert B - Wert C - Wert D - Wert E - Wert F - 2 - Wert G - Wert H - Wert I
Wert X - Wert K - Wert L - Wert M - Wert N - Wert O - 1 - Wert P - Wert Q - Wert R
Wert 1 - Wert 2 - Wert 3 - Wert 4 - Wert 5 - Wert 6 - 3 - Wert 8 - Wert 9 - Wert 10


Soll daraus folgende Tabelle generiert werden:

Wert A - Wert B - Wert C - Wert D - Wert E - Wert F - 1 - Wert G - Wert H - Wert I
Wert A - Wert B - Wert C - Wert D - Wert E - Wert F - 1 - Wert G - Wert H - Wert I
Wert X - Wert K - Wert L - Wert M - Wert N - Wert O - 1 - Wert P - Wert Q - Wert R
Wert 1 - Wert 2 - Wert 3 - Wert 4 - Wert 5 - Wert 6 - 1 - Wert 8 - Wert 9 - Wert 10
Wert 1 - Wert 2 - Wert 3 - Wert 4 - Wert 5 - Wert 6 - 1 - Wert 8 - Wert 9 - Wert 10
Wert 1 - Wert 2 - Wert 3 - Wert 4 - Wert 5 - Wert 6 - 1 - Wert 8 - Wert 9 - Wert 10


Die Anzahl der Datensätze und die Höhe und Häufigkeit des Zahlenwertes der das Zellenkopieren bei Abweichung von 1 auslöst sind variabel. Dazu habe ich folgendes Makro erstellt und auch in einer kleinen Tabelle mit 200 Datensätzen erfolgreich getestet.

Setze ich das Makro nun bei der Zieltabelle ein die rund 3000 Zeilen und einige Zellen mit einem Zielwert > 1 beinhaltet (bis 200), hängt sich Excel nach etwa 5-10 Sekunden auf.  Ich habe es auch schon laufen lassen und gehofft, dass trotz "keiner Rückmeldung" die Rechnung weiter geht - dem war aber leider nicht so.

Habe ich etwas bei dem Makro falsch gemacht oder gibt es eine andere Möglichkeit das Problem zu lösen damit sich Excel nicht mehr aufhängt?

Hier das Makro:

Code:
Sub Zeileneinfuegen()

   Dim LastRow As Long
   With ActiveSheet
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With


Dim i     As Integer
Dim zw    As Integer
Dim zwi    As Integer


For i = LastRow To 1 Step -1
 If Cells(i, 7).Value <> "1" Then
    zw = Cells(i, 7).Value
    Cells(i, 7).Value = "1"
   
 For zwi = 2 To zw
    Rows(i).Copy
    Rows(i + 1).Insert Shift:=xlDown
    Next zwi

     
 End If
Next i

End Sub


Ich Danke euch vielmals vorab.
Antwortento top
#2
Hallo,

so vielleicht:

Code:
Sub Zeileneinfuegen()
 Dim i As Long
 Dim LastRow As Long
 
 With ActiveSheet
     LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
 End With

 For i = LastRow To 1 Step -1
   If IsNumeric(Cells(i, 7).Value) Then
     If Cells(i, 7).Value > 1 Then
       Rows(i).Copy
       Rows(i).Resize(Cells(i, 7).Value - 1).Insert
     End If
   End If
 Next i
End Sub

Gruß Uwe
Antwortento top
#3
Hallo Bjoux,
vielleicht lässt sich Dein Problem mit
application.screenupdating=false'vor for i=...
und
application.screenupdating=true'nach next i
lösen, dann hat Excel nicht so viel zu tun...
Bei mir ging es mit 3000 Zeilen (und einer kleinen Pause) eigentlich gut.
Gruß der AlteDresdner
Gruß der AlteDresdner (Win10, Off2010)
Antwortento top
#4
Hallo,

hier noch eine Arrayvariante:

Code:
Sub Zeileneinfuegen()
 Dim lngZeileQ As Long, lngZeileZ As Long, lngSpalte As Long
 Dim varQ As Variant, varZ As Variant
 lngZeileZ = 1
 varQ = Cells(1, 1).CurrentRegion.Value
 ReDim varZ(1 To Application.CountA(Columns(7)) - Application.Count(Columns(7)) + Application.Sum(Columns(7)), 1 To UBound(varQ, 2))
 For lngZeileQ = 1 To UBound(varQ, 1)
   If IsNumeric(varQ(lngZeileQ, 7)) Then
     For lngZeileZ = lngZeileZ To lngZeileZ + varQ(lngZeileQ, 7) - 1
       For lngSpalte = 1 To UBound(varQ, 2)
         varZ(lngZeileZ, lngSpalte) = varQ(lngZeileQ, lngSpalte)
       Next lngSpalte
       varZ(lngZeileZ, 7) = 1
     Next lngZeileZ
   Else
     For lngSpalte = 1 To UBound(varQ, 2)
       varZ(lngZeileZ, lngSpalte) = varQ(lngZeileQ, lngSpalte)
     Next lngSpalte
     lngZeileZ = lngZeileZ + 1
   End If
 Next lngZeileQ
 Cells(1, 1).Resize(UBound(varZ, 1), UBound(varZ, 2)).Value = varZ
End Sub

Gruß Uwe
Antwortento top
#5
Vielen Dank für Eure Hilfe.

Eine Mischung aus den ersten beiden hat nun zum Erfolg geführt.

Excel wirkt zwar als ob es sich aufhinge, wenn man jedoch 1-2 Minuten wartet, sind die Resultate auch bei großen Datenmengen korrekt.

Herzlichsten Dank!
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste