VBA Zeilen nach Kriterium in neue Tabelle kopieren

[hagmanma]

Hallo liebes Forum,

Ich stehe mit VBA erst ganz am Anfang und habe nun ein Problem,
welches für die meisten von Euch vermutlich in ein paar Minuten erledigt wäre.
Wäre super wenn mir hier jemand helfen könnte.

Ich erhalte aus einem Programm eine Excel Tabelle (Tabelle X)mit ca 500 Adressen der Handwerker mit denen wir zusammen arbeiten.
Nun möchte ich daraus eine Tabelle (Tabelle Y) generieren die nach BranchenCode (Tabelle X.Spalte H) geordnet ist, mit Titelzeile für die jeweilige Branche.
Ein Handwerker kann mehrere BranchenCodes in der Zelle haben (zb 201.1; 211.0; 421.0).
Demzufolge kann er auch mehrmals in der fertigen Tabelle Y auftauchen

Meine Idee bis jetzt:

- Kopiere die Tabelle X manuell in Tabelle Y.Blatt1 (Tabelle Y soll das VBA drinn haben)
- Button drücken auf Tabelle Y.Blatt1 löst folgendes aus:

- Erstelle neues Tabellenblatt (Blatt2) in Tabelle Y
- Schreibe Titelzeile „201.1“ in Tabelle Y.Blatt2
- Schlaufe – kopiere alle Zeilen von Tabelle Y.Blatt1, welche in Spalte H *201.1* stehen haben (vor und nach 201.1 könnten noch weitere Branchen stehen) in TabelleY.Blatt2
- Schreibe Leere Zeile
- Schreibe Titelzeile „211.0“ in Tabelle Y.Blatt2
- Schlaufe – kopiere alle Zeilen von Tabelle Y.Blatt1, welche in Spalte H *211.0* stehen haben (vor und nach 211.0 könnten noch weitere Branchen stehen) in TabelleY.Blatt2
- Schreibe Leere Zeile

und so weiter bis alle Branchencodes (ca 20 Stück, ändern sich nie) abgearbeitet sind.

Soweit so gut… Nur, wie setz ich das um?

Ach ja… einen Button machen und das VBA damit verknüpfen ist kein Problem.
Es ist wirklich nur der Code wo ich nicht weiss wie anfangen.

Vielen Dank für Eure Zeit!!!

Gruss
Martin

[Steffl]

Hallo Martin,

mal als erster Ansatz mit dem Spezialfilter

Datentabelle heißt Tabelle1 und umfasst die Spalten A bis H, Kriterienauswahl für den Spezialfilter ist der Bereich K1:K2

Eingefügt wird es in Tabelle2. Habe es ein klein wenig kommentiert.

Code:

Sub prcVersuch()
  Dim objArrLst As Object
  Dim lngC As Long, lngA As Long
  Dim vntArray As Variant
 
  'Verweis auf die Bibliothek
  Set objArrLst = CreateObject("System.collections.arraylist")
  With Worksheets("Tabelle1") 'Tabellennamen anpassen
     For lngC = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row
        'falls in Zelle H... ein ; vorhanden ist
        If InStr(1, .Cells(lngC, 8).Value, ";") Then
           'splitte den Eintrag an den ;
           vntArray = Split(.Cells(lngC, 8), ";")
           For lngA = 0 To UBound(vntArray)
              'falls Eintrag nicht vorhanden ist, nehme ihn auf
              If Not objArrLst.contains(CVar(vntArray(lngA))) Then objArrLst.Add CVar(vntArray(lngA))
           Next lngA
        Else
           'bei einzeleinträgen erfolgt auch die notwendige Prüfung ob vorhanden
           If Not objArrLst.contains(.Cells(lngC, 8).Value) Then objArrLst.Add .Cells(lngC, 8).Value
        End If
     Next lngC
     'das Array wird sortiert (falls nicht gewünscht kann es entfernt werden
     objArrLst.Sort
     'eintragung der Branchenüberschrift von H1 in K1
     .Range("K1").Value = .Range("H1").Value
  End With
  'Tabelle2 muss aktiviert werden Namen anpassen!
  Worksheets("Tabelle2").Activate
  'Die Arrayliste wird durchlaufen
  For lngA = 0 To objArrLst.Count - 1
     With Worksheets("Tabelle2")
        'Element wird als Überschrift für den Eintrag verwendet
        .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 2, 1).Value = objArrLst(lngA)
        '... und als Eintrag für den Spezialfilter
        Worksheets("Tabelle1").Range("K2").Value = "*" & objArrLst(lngA) & "*"
        Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("Tabelle1!K1:K2"), _
        CopyToRange:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1), Unique:=False
     End With
  Next lngA
  Set objArrLst = Nothing
End Sub

[hagmanma]

Hallo Stefan,
ich probiere Deinen Code gleich aus.

in der Zwischenzeit habe ich folgendes gebastelt.
Das gibt mir immerhin schon mal ein neues Tabellenblatt,
schreibt den ersten Titel BKP 201.1 und kopiert auch
die ersten Datensätze. Nur komm ich nicht weiter damit.
sprich, nächsten Branchencode bearbeiten und die Daten
kopieren. Ich glaub ich hab bei den Zählern auch ein
wenig den Überblick verloren.

Gruss
Martin

Option Explicit

Sub NachBrancheTrennen()

Dim Zeile As Long
Dim ZeileMax As Long ' Anzahl Zeilen Ursprungstabelle
Dim n As Long ' Zeilenzähler Ursprungstabelle
Dim Zeilenzaehler As Long ' Zeilenzähler neue Tabelle Unternehmerliste

Sheets.Add
ActiveSheet.Name = "Unternehmerliste"

Zeilenzaehler = 1 ' Unternehmerliste Zeile 1

' schreibe Titelzeile BKP 201.1 in Zeile 1
Worksheets("Unternehmerliste").Range("A1").Value = "BKP 201.1"
Zeilenzaehler = Zeilenzaehler + 1

'Unternehmerliste ist nun auf Zeile 2

' Abfrage BKP 201.1
With Tabelle1
ZeileMax = .UsedRange.Rows.Count
n = 2 ' erste Zeile ist nur ein Titel deswegen 2

For Zeile = 2 To ZeileMax

If .Cells(Zeile, 8).Value Like "*201.1*" Then

.Rows(Zeile).Copy Destination:=Sheets("Unternehmerliste").Rows(n)
n = n + 1
Zeilenzaehler = Zeilenzaehler + 1


End If
Next Zeile
End With

End Sub