Einzelne Zeilen aus Tabelle in Array

Liebe Forumsmitglieder,
Ich versuche seit geschlagener Zeit, einzelne Zeilen (durch ein If-Kriterium ausgewählt) in ein Array untereinander einzulesen, sodass ich sie als eigene Tabelle wieder ausgeben kann.
Die Ausgangstabelle hat etwa 120.000 Zeilen und 10 Spalten. In der zweiten Spalte steht eine Nummer, die jede Zeile einer Gruppe zuordnet(Wobei die Gruppen völlig unterschiedliche Anzahlen an Zeilen haben). Ich will auf einem anderen Datenblatt sagen können: Nehme Gruppe 5 und dort sollen dann alle Zeilen aus der Ausgangstabelle aus Gruppe 5 untereinander stehen.
Meine Idee war in etwa:
For actRow 2 to 120.000
If Cells(actRow,2) = Cells(Die Zelle, die die Auswahl 5 beinhaltet)
"An dieser Stelle müsste ein Code stehen, der den Array an der ersten freien Stelle mit allen 10 Spalten dieser Zeile befüllt"
End if
Next actRow
Ich kann also die Länge des Arrays nicht vordefinieren, da sie sich je nach Auswahl der Gruppe unterscheidet.
Ich bin kein sonderlich versierter VBA-Spezialist und bringe mir das gerade selbst bei, also geht schonend mit mir um. Gesucht habe ich auch, aber vielleicht weiß ich nicht, wonach ich suchen muss.
Vielen Dank für die Hilfe und liebe Grüße
Thorsten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() Dim Gruppe As String Dim actRow As Long Dim actRow2 As Long Dim arr() As Variant Dim iCounter As Long Dim arrCounter As Long iCounter = 0 arrCounter = 0 Gruppe = Cells(1, 5) iZeile = Worksheets("Alle Artikel").Cells(Rows.Count, 1).End(xlUp).Row For actRow = 2 To iZeile If Worksheets("Alle Artikel").Cells(actRow, 2) = Gruppe Then iCounter = iCounter + 1 End If Next actRow ReDim arr(iCounter - 1, 0) For actRow2 = 2 To iZeile If Worksheets("Alle Artikel").Cells(actRow, 2) = Gruppe Then arr(arrCounter, 0) = Worksheets("Alle Artikel").Cells(actRow2, 1) arr(arrCounter, 1) = Worksheets("Alle Artikel").Cells(actRow2, 2) arr(arrCounter, 2) = Worksheets("Alle Artikel").Cells(actRow2, 3) arr(arrCounter, 3) = Worksheets("Alle Artikel").Cells(actRow2, 4) arr(arrCounter, 4) = Worksheets("Alle Artikel").Cells(actRow2, 5) arr(arrCounter, 5) = Worksheets("Alle Artikel").Cells(actRow2, 6) arr(arrCounter, 6) = Worksheets("Alle Artikel").Cells(actRow2, 7) arr(arrCounter, 7) = Worksheets("Alle Artikel").Cells(actRow2, 8) arr(arrCounter, 8) = Worksheets("Alle Artikel").Cells(actRow2, 9) arr(arrCounter, 9) = Worksheets("Alle Artikel").Cells(actRow2, 10) arrCounter = arrCounter + 1 End If Next actRow2 End Sub

Hallo Werner,
wie bei deinen Codes nicht anders zu erwarten funktioniert diese Lösung viel schneller! Vielen Dank zunächst dafür.
Jetzt kommt das (hoffentlich letzte) aber: In dem neuen Code wird der Excel Zwischenspeicher leider gelöscht. Da die Gruppen in der Realität aus 10stelligen Nummern bestehen, ist ein manuelles Eintippen in die ComboBox1 leider nicht sehr praktikabel. So langsam habe ich den Eindruck, dass das Erstellen eines Dropdown Menüs das Ganze unnötig verkompliziert, da bei 1900 Gruppen das Dropdown Menü eh kaum benutzbar ist. Ich habe jetzt beide Codes nebeneinander gestellt und versucht, herauszufinden wo im Zweiten Code der Zwischenspeicher beim Aufrufen der UserForm gelöscht wird... Ohne Erfolg.
Würde sich der Code stark vereinfachen, wenn einfach ein Textfeld anstatt der ComboBox in der Userform steht? Und welcher Codebestandteil sorgt für das Löschen des Excel Zwischenspeichers? Anbei noch einmal dein Code (Unten leicht von mir abgeändert, weil ich dachte die auskommentierten Zeilen löschen den Speicher/ Machen sie aber nicht):

Option Explicit
Private Sub ComboBox1_Change()
End Sub
Private Sub CommandButton1_Click()
Dim varFilter As Variant, loLetzteQuelle As Long
Dim loLetzteZiel As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual   'Unterschied
With Worksheets("Ausgangstabelle")
varFilter = Me.ComboBox1
If WorksheetFunction.CountIf(.Columns("B"), varFilter) = 0 Then
MsgBox "Fehler: Diese Gruppe gibt es nicht."
Me.ComboBox1.ListIndex = -1
Me.ComboBox1.SetFocus
Exit Sub
End If
If Me.ComboBox1.ListIndex > -1 Then
With Worksheets("Zieltabelle")
loLetzteZiel = .Cells(.Rows.Count, "B").End(xlUp).Row
If loLetzteZiel > 2 Then
.Range(.Cells(3, "A"), .Cells(loLetzteZiel, "J")).ClearContents
End If
End With
loLetzteQuelle = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(1, "A"), .Cells(loLetzteQuelle, "J")).AutoFilter field:=2, Criteria1:= _
varFilter
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Zieltabelle").Range("A3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
.AutoFilter.ShowAllData
Else
MsgBox "Fehler: Bitte eine Gruppe auswählen."
Me.ComboBox1.SetFocus
Exit Sub
End If
End With
Range("A2").Select
Unload Me
Application.Calculation = xlCalculationAutomatic  'Unterschied
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim actRow As Long
Dim iZeile As Long
iZeile = Worksheets("Ausgangstabelle").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Hilfstabelle").Columns(2).ClearContents
For actRow = 1 To iZeile
Worksheets("Hilfstabelle").Cells(actRow, 2) = Worksheets("Ausgangstabelle").Cells(actRow, 2) _
Next actRow
'Worksheets("Ausgangstabelle").Columns(2).Copy Worksheets("Hilfstabelle").Columns(2)
'Columns("B:B").Select
With Worksheets("Hilfstabelle")
.Range("$B$1:$B$" & .Cells(.Rows.Count, "B").End(xlUp).Row).RemoveDuplicates _
Columns:=1, Header:=xlYes
Me.ComboBox1.List = .Range("$B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Einzelne Zeilen aus Tabelle in Array

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Einzelne Zeilen aus Tabelle in Array

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread