Zeilen trotz Aufteilung übernehmen
29.11.2016 10:42:15
Julia
da ich von VBA nicht so viel Ahnung habe und hier auch echt nicht weiterkomme, habe ich mal nachfolgend meinen Code aufgeführt.
Ich möchte damit aus einer Gesamtliste (ZB) die einzelnen Begriffe (die mehrfach vorkommen) raussuchen und die zugehörigen Zeilen komplett in einem neuen Tabellenblatt zusammenkopieren , d.h. wenn ein Begriff auf dem Tabellenblatt "ZB" insgesamt fünf mal vorkommt, so soll er diese Zeilen nehmen und in eine neues Tabellenblatt schreiben, welches den Namen des Begriffes trägt (dort sind dann quasi 5 Zeilen beschrieben)
Code funktioniert auch super, aber ich komm bei dem letzten Problem nicht weiter:
Die Zeilen 1-8 vom ZB-Blatt will ich auch auf den ganzen anderen Blättern, die entstanden sind, haben! Und dieses gelingt mir nicht :-(. (ich vermute mal, dass es mit dem X1up zu tun hat, da er von "unten" loszählt, oder?
Kann mir da jemand weiterhelfen?
mein Code:
Sub DatenInExtraBlatt()
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngLZQ As Long
Dim lngLZZ As Long
Dim zell As Range
Dim Dic As Object
Dim keyD As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Set wksQ = Worksheets("ZB") 'ggf. ANPASSEN
For Each wksZ In Worksheets
Dic(wksZ.Name) = ""
Next
lngLZQ = wksQ.Cells(wksQ.Rows.Count, 3).End(xlUp).Row '3=SpalteC
For Each zell In wksQ.Range("B2:B" & lngLZQ)
If zell.Value "" Then
If Not Dic.Exists(zell.Value) Then
Dic(zell.Value) = "clear"
Set wksZ = Worksheets.Add(After:=Sheets(Sheets.Count))
wksZ.Name = zell.Value
Else
Set wksZ = Worksheets(zell.Value)
If Dic(zell.Value) "clear" Then
Dic(zell.Value) = "clear"
wksZ.UsedRange.Clear 'Zieltabelle säubern
End If
End If
lngLZZ = wksZ.Cells(wksZ.Rows.Count, 3).End(xlUp).Row '3=SpalteC
zell.EntireRow.Copy wksZ.Range("A" & lngLZZ + 1)
End If
Next
End Sub