Suchen und kopieren mit variabler Liste

Hallo Leute,
ich hab hier noch mal ein kleines VBA-Problem welches für die meisten von euch wahrscheinlich ziemlich basic ist mir aber gerade großes Kopfzerbrechen und Performanceprobleme bereitet:
Ausgangssituation:
Tabelle "Liste" enthält (als Pivot) in Spalte B eine Liste mit ID-Nummern der zu kopierenden Datensätze, bspw.:
28
38
4
56
57
59
111
Tabelle "Quelle" enthält alle Datensätze in unsortierter Reihenfolge. Die o.g. genannte ID steht in Spalte A.
Tabelle "Ziel" enthält noch nichts, soll aber die Zeilen enthalten deren ID-Nummer in der "Liste" steht.
Bisheriger Ansatz:
Durchlaufe "Liste" mit for-Schleife bis zur letzten Zeile und durchsuche "Quelle" Spalte A für jede "Liste"n-zeile nach der ID. Wenn ID gefunden, kopiere komplette Zeile nach "Ziel".
Problem:
Mein Ansatz (s.o.) läuft bei gerade einmal 100 Datensätzen und ~40 Spalten ca. 30s. Da es bei jeder Veränderung einer Pivottabelle getriggert werden soll (bereits gelöst), ist so eine lange Laufzeit nicht praktikabel. Gibt es evtl. noch eine elegantere Methode?
Vielen Lieben Dank euch und ein schönes Wochenende!
Pochi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Pochi,
eine Möglichkeit zur Beschleunigung:
In der Quelltabelle mit dem Autofilter arbeiten, dann kann man alle Werte aus der Pivot als Array für die Filterwerte übergeben. Im Zielblatt müssen die kopierten Zeilen ggf. noch nach der ID-sortiert werden, wenn diese als Zeilenblöcke vorliegen sollen. Diese Methode kopiert allerdings keine Formeln, sondern nur Formate und Werte.
Zusätzlich kann evtl. noch Beschleunigung erreichen, indem während der Makroausführung die Bildschirmaktualiierung deaktiviert und der Berechnungsmodus auf Manuel geetzt wird.
Nachfolgend ein Beispielmakro. Tabellennamen sowie Zeilen und Spaltennummern musst du ggf. anpassen.
Gruß
Franz

Sub Filtern()
Dim wksPivot As Worksheet, wksQ As Worksheet, wksZ As Worksheet
Dim ZeileP As Long, ZeileQ As Long, ZeileZ As Long
Dim arrFilter() As String, intF As Integer
Set wksQ = ActiveWorkbook.Worksheets("Quelle")
Set wksZ = ActiveWorkbook.Worksheets("Ziel")
Set wksPivot = ActiveWorkbook.Worksheets("Pivot")
'Filterwerte in Pivot in Array einlesen
With wksPivot
For ZeileP = 5 To .Cells(.Rows.Count, 2).End(xlUp).Row
With .Cells(ZeileP, 2)
If .Value  "" Then
intF = intF + 1
ReDim Preserve arrFilter(1 To intF)
arrFilter(intF) = .Text
End If
End With
Next
End With
If intF > 0 Then
With wksQ
'Autofilter in Quelle vorbereiten
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
Else
ZeileQ = .Cells.SpecialCells(xlCellTypeLastCell).Row
.Range(.Rows(1), .Rows(ZeileQ)).AutoFilter
End If
ZeileQ = .Cells.SpecialCells(xlCellTypeLastCell).Row
'Autofilter setzen für Spalte mit ID-Werten
.AutoFilter.Range.AutoFilter Field:=2, Criteria1:=arrFilter, Operator:=xlFilterValues
ZeileQ = .Cells.SpecialCells(xlCellTypeLastCell).Row
If ZeileQ = 1 Then
MsgBox "keine Zeilen zu Filterwerten in Quelltabelle gefunden"
Else
'nächste freie Zeile in Spalte mit ID
ZeileZ = wksZ.Cells(wksZ.Rows.Count, 2).End(xlUp).Row + 1
.Range(.Rows(2), .Rows(ZeileQ)).Copy wksZ.Cells(ZeileZ, 1)
End If
'in Quelle alle Daten wieder anzeigen
.ShowAllData
'kopierte Daten in Zieltabelle nach der ID in Spalte B sortieren
With wksZ
With .Range(.Rows(ZeileZ), .Rows(.Cells(.Rows.Count, 2).End(xlUp).Row))
.Sort key1:=.Range("B1"), Order1:=xlAscending, Header:=xlNo
End With
End With
End With
Erase arrFilter
Else
MsgBox "keine Filterwerte in Pivottabelle gefunden"
End If
End Sub

Sub Suche() Dim i, o As Integer Application.ScreenUpdating = False Application.EnableEvents = False For i = 1 To Worksheets("Liste").UsedRange.SpecialCells(xlCellTypeLastCell).Row For o = 1 To Worksheets("Quelle").UsedRange.SpecialCells(xlCellTypeLastCell).Row If Worksheets("Liste").Cells(i, 2) = Worksheets("Quelle").Cells(o, 1) Then Worksheets("Quelle").Rows(o).Copy Worksheets("Ziel").Cells(Worksheets("Ziel").UsedRange.SpecialCells( _ xlCellTypeLastCell).Row, 1).PasteSpecial Exit For End If Next o Next i Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Sub Suche() Dim i, o As Integer Application.ScreenUpdating = False Application.EnableEvents = False For i = 1 To Worksheets("Liste").UsedRange.SpecialCells(xlCellTypeLastCell).Row For o = 1 To Worksheets("Quelle").UsedRange.SpecialCells(xlCellTypeLastCell).Row If Worksheets("Liste").Cells(i, 2) = Worksheets("Quelle").Cells(o, 1) Then Worksheets("Quelle").Rows(o).Copy Worksheets("Ziel").Cells(Worksheets("Ziel").UsedRange.SpecialCells( _ xlCellTypeLastCell).Row + 1, 1).PasteSpecial Exit For End If Next o Next i Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

Suchen und kopieren mit variabler Liste

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suchen und kopieren mit variabler Liste

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread