VBA-Zusammenhängende Zeilen ausschneiden

Hallo lieber VBA Profis,
Ich habe gerade eine gewisse Herausforderung vor mir und kann diese leider gar nicht richtig in wenigen Worten beschreiben. Am ehesten noch als Thematisch zusammenhängende Zeilen ausschneiden und in ein neues Tabellenblatt kopieren.
Ich habe CSV Dateien auf verschiedenen CDs die alle nahezu gleich aufgebaut sind. Pro CD eine CSV. Diese kann ich mittels Makro (Workbooks.OpenText - Cells.Select / copy / paste usw.) in mein Hauptfile, als neues Tabellenblatt integrieren. Soweit so gut :-)
In den ersten beiden Zeilen befinden sich Informationen zu der CD, diese kann ich mittels Makro selbst auslesen und verwerten.
In den folgenden Zeilen muss ich nach verschiedenen Kriterien, Zeilen ausschneiden und in ein neues Tabellenblatt einfügen.
Konkret:
In Spalte A steht die Bezeichnung Unternehmen oder die jeweils dazugehörige(n) Filiale (Es stehen wirklich immer nur diese beiden Worte in Spalte A, ab Zeile 3)
Wie viele Filialen zu dem Unternehmen gehören steht in Spalte H.
Es sieht also ca. so aus:
Unternehmen - - - - - - 5
Filiale
Filiale
Filiale
Filiale
Filiale
Unternehmen - - - - - 3
Filiale
Filiale
Filiale
Usw. usw.
An diesem Punkt hänge ich. Wie soll ein Makro aussehen, dass wenn in Spalte A Unternehmen steht, schneide die Zeile + die nächsten (Wert aus H) Zeilen aus und füge sie in ein neues Tabellenblatt ein?
Ich dachte an etwas wie eine For i / next i Schleife in welcher if Spalte A = Unternehmen Rows.(H).cut drin steht. Leider steh ich hier aber total auf dem Schlauch und finde durch die Schwierigkeit mein Anliegen zu formulieren auch nichts im Forum darüber.
Ich wäre für jede Hilfe wirklich sehr dankbar!
Liebe Grüße,
Michael

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub test() Dim ws As Worksheet Dim ws2 As Worksheet Dim Companys() As Variant Dim tmp As Variant Dim i As Long Dim idx As Long Dim lRow As Long Set ws = ThisWorkbook.Sheets(1) 'anpassen Set ws2 = ThisWorkbook.Sheets(2) 'anpassen With ws lRow = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 3 To lRow If .Cells(i, 1).Value = "Unternehmen" Then ReDim Preserve Companys(1 To 2, idx) Companys(1, idx) = i Companys(2, idx) = .Cells(i, 8).Value idx = idx + 1 End If Next i For i = 0 To idx - 1 .Range(.Cells(Companys(1, i), 1), _ .Cells(Companys(1, i) + Companys(2, i) - 1, 1)).Copy With ws2 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Range(.Cells(lRow, 1), .Cells(lRow, 1)).PasteSpecial xlPasteValues End With Application.CutCopyMode = False Next i End With End Sub

Hallo Peter (und alle anderen),
Danke für diesen tollen Entwurf. Einiges davon habe ich gleich anpassen und verwenden können!
Folgende kleine Änderungen habe ich vorgenommen:

Sub test()
Dim ws          As Worksheet
Dim ws2         As Worksheet
Dim Companys()  As Variant
Dim tmp         As Variant
Dim i           As Long
Dim idx         As Long
Dim lRow        As Long
Set ws = ThisWorkbook.Sheets("CD 16159")
Set ws2 = ThisWorkbook.Worksheets.Add    'Funktioniert nicht so wie ich es will
With ws
'Wie viele Zeilen gibt es im Tabellenblatt?
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
'Speichern der "Unternehmen"-Bereiche mit den POS Zeilen darunter
If .Cells(i, 1).Value = "Unternehmen" Then
ReDim Preserve Companys(1 To 2, idx)
Companys(1, idx) = i
Companys(2, idx) = .Cells(i, 8).Value
idx = idx + 1
End If
Next i
For i = 0 To idx - 1
'Kopieren ------ab der 3ten Zeile----------Zelle ----A1+A2 also A3 -------bis A15
.Range(.Cells(Companys(1, i), 1), .Cells(Companys(1, i) + Companys(2, i), 15)).Copy  _
'Ich kopiere hier nicht nur die erste Spalte, sondern alle 15
'Unter dem letzten Listeneintrag in Tabelle "Ws2" einfügen
ws2
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range(.Cells(lRow, 1), .Cells(lRow, 1)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next i
End With
End Sub

Das Problem steckt im ws2 Teil gleich am Anfang. Ich möchte (und da habe ich mich in meiner Beschreibung zu unklar ausgedrückt sorry) jeden Block in ein eigenes Tabellenblatt, nicht alle in dasselbe Blatt kopieren.
Es soll also jeder Unternehmen/Filiale Block ein eigenes Tabellenblatt bekommen. So kann ich die Daten dann separiert weiter bearbeiten.
Ich bedanke mich schon einmal im Voraus für die tolle Unterstützung!
Liebe Grüße,
Michael

Option Explicit Sub test() Dim ws As Worksheet Dim ws2 As Worksheet Dim Companys() As Variant Dim tmp As Variant Dim i As Long Dim idx As Long Dim lRow As Long Set ws = ThisWorkbook.Sheets(1) 'anpassen With ws lRow = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 3 To lRow If .Cells(i, 1).Value = "Unternehmen" Then ReDim Preserve Companys(1 To 2, idx) Companys(1, idx) = i Companys(2, idx) = .Cells(i, 8).Value idx = idx + 1 End If Next i For i = 0 To idx - 1 .Range(.Cells(Companys(1, i), 1), _ .Cells(Companys(1, i) + Companys(2, i) - 1, 15)).Copy Set ws2 = ws.Parent.Sheets.Add(After:=ws.Parent.Sheets(ws.Parent.Sheets.Count)) With ws2 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Range(.Cells(lRow, 1), .Cells(lRow, 1)).PasteSpecial xlPasteValues End With Application.CutCopyMode = False Next i End With End Sub

Beliebteste Forumthreads (12 Monate)

VBA-Zusammenhängende Zeilen ausschneiden

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread