Clever-Excel-Forum

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.

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

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

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

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!

Bjoux

Kuwer

AlterDresdner

Kuwer

Bjoux