Clever-Excel-Forum

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

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

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

hagmanma

Steffl

hagmanma