Bereich suchen und extrahieren
22.08.2023 17:09:13
Peter
ich habe eine Tabelle aus der ich regelmäßig Daten hereinkopiert bekomme. Die Daten kommen aus einem gesonderten Programm und wir können das so schnell nicht ändern.
Jetzt würde ich sie gerne in den Blöcken, in denen die Daten importiert werden in ein jeweils seperates Arbeitsblatt in die erste freie Zeile kopieren.
Das einzige was die Blöcke unterscheidet sind die Indexnamen in Spalte A. Die sind aufgebaut in Spalte A NAME#1 zu NAME#1 (Anfang1,Ende1 in der Tabelle).
Leider wird kein Wert in den eigendlichen Daten hinterlegt, mit denen man einfach Filtern könnte.
Ohne die Indexnamen kann man also von außen nicht nachvollziehen, ob zeile x aus Block NAME#1 kommt oder nicht
Die Blöcke sind variabel in der Zeilenanzahl, aber relativ statisch im der Spaltenanzahl. Deshalb sind die Spalten Fest B:Q.
So stelle ich mir das gerade vor:
Sub extrahieren()
Dim shtQuelle As Worksheet, shtZiel1 As Worksheet, shtZiel2 As Worksheet ' shtZiel3...shtZiel10 usw.
Dim Rng1 As Range
Dim Rng2 As Range
'auch hier Rng3...Rng10 usw.
Dim zlr1 As Long
Dim zlr2 As Long
'...
Set shtQuelle = Worksheets("2023")
Set shtZiel1 = Worksheets("Ziel1")
Set shtZiel2 = Worksheets("Ziel2")
'...
'firstrow suchen
fr1 = shtQuelle.Cells.Find("Anfang1", _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1 '+1 weil die Daten erst eine Zeile darunter anfangen
'lastrow suchen
lr1 = shtQuelle.Cells.Find("Ende1", _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row - 1 '-1 weil die Daten schon eine Zeile darüber aufhören
'lastrow im Ziel1 suchen
zlrl = shtZiel1.Cells(Rows.Count, "B").End(xlUp).Row
'lastrow im Ziel2 suchen
zlr2 = shtZiel1.Cells(Rows.Count, "B").End(xlUp).Row
Set Rng1 = shtQuelle.Range(""B" & fr1" : ""Q" & lr1") ' weiß nicht wie ich das verknüpfen kann =/
Rng1.Copy shtZiel1.Cells(zlrl, 2)
fr2 = shtQuelle.Cells.Find("Anfang2", _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
lr2 = shtQuelle.Cells.Find("Ende2", _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row - 1
Set Rng2 = shtQuelle.Range(""B" & fr2" : ""Q" & lr2")
Rng2.Copy shtZiel2.Cells(zlr2, 2)
End Sub
Beispieldatei:
https://www.herber.de/bbs/user/162439.xlsm
Knallhart Zenziert... aber bis auf die Daten fast so blank wie im Original =)
Hoffentlich habe ich mich verständlich ausgedrückt.
Schon mal vielen Dank für eure Hilfe
Schöne Grüße
Peter