Performance-Problem mit Array lösen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi
die Innere Schleife kannst du dir sparen, wenn du beim Einfügen als Ziel nicht nur die linke obere Zelle angibst, sondern den gesamten Bereich der ausgefüllt werden soll. Excel dupliziert dann beim Einfügen die Zellen entsprechend.
dh mit Rows(1).Copy Destination:=Rows(2).Resize(10) wird die Zeile 1 beim einfügen 10x dupliziert.
die fortlaufenden Nummern in Spalte 2 und Spalte 7 kannst du dann mit Inhalte ausfüllen - Reihe in einem Schritt erzeugen.
sieht als Code dann so aus:

Sub test()
Dim Zelle As Range
With Sheets("Tabelle2")
.Cells.Clear
Sheets("Tabelle1").Rows(1).Copy .Cells(1, 1)
For Each Zelle In Sheets("Tabelle1").Columns(1).SpecialCells(xlCellTypeConstants, 2)
If Zelle.Value = "kopieren" Then
Zelle.Resize(, 7).Copy
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) _
.Resize(Zelle.Offset(0, 1).Value + 1, 7)
.PasteSpecial xlPasteAll
.Columns(2).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=-1
.Columns(7).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
End With
End If
Next
End With
End Sub

beim Arbeiten mit Arrays muss man beachten, dass ein Redim Preseve (redim mit erhalt der Inhalte) nur mit der jeweils letzten Dimension funktioniert.
in deinem Fall wäre es aber durchaus möglich, das Ergebnisarray schon vorab auf die richtige Größe zu dimensionieren, weil du ja einfach nur die Werte aus Spalte 2 bei denen "kopieren" steht, addieren (dazu gibt's ja SummeWenn bzw Worksheetfunction.SumIf in VBA) und dann nochmal die Anzahl selbst hinzufügen musst.
Gruß Daniel

Hallo Sven,
hier eine reine Array-Lösung:

Option Explicit

Public Sub CopyFill()

    Const COPY_CRITERIA As String = "kopieren" ' Anpassen !!!

    Dim avntInput As Variant, avntOutput() As Variant
    Dim ialngInputIndex1 As Long, ialngInputIndex2 As Long
    Dim ialngOuputIndex1 As Long, ialngOuputIndex2 As Long
    Dim lngPlusCounter As Long, lngMinusCounter As Long

    With Worksheets("Tabelle1") ' Anpassen !!!
        avntInput = .Range(.Cells(2, 1), .Cells(.Rows.Count, 7).End(xlUp)).Value
    End With

    ialngOuputIndex1 = 1

    For ialngInputIndex1 = 1 To UBound(avntInput, 1)

        If avntInput(ialngInputIndex1, 1) = COPY_CRITERIA Then

            lngMinusCounter = avntInput(ialngInputIndex1, 2)
            lngPlusCounter = 1

            Redim Preserve avntOutput(1 To 7, 1 To ialngOuputIndex1 + lngMinusCounter)

            For ialngInputIndex2 = 1 To lngMinusCounter + 1

                For ialngOuputIndex2 = 1 To 6

                    avntOutput(ialngOuputIndex2, ialngOuputIndex1) = _
                        avntInput(ialngInputIndex1, ialngOuputIndex2)

                Next

                avntOutput(2, ialngOuputIndex1) = lngMinusCounter
                avntOutput(7, ialngOuputIndex1) = lngPlusCounter

                lngMinusCounter = lngMinusCounter - 1
                lngPlusCounter = lngPlusCounter + 1
                ialngOuputIndex1 = ialngOuputIndex1 + 1

            Next
        End If
    Next

    With Worksheets("Tabelle2") ' Anpassen !!!
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _
            UBound(avntOutput, 2), 7) = Application.Transpose(avntOutput)
    End With

End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Performance-Problem mit Array lösen?

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread