Bedingtes ausschneiden in neue Zeile mit VBA

Hallo zusammen,
ich habe schon häufiger in diesem Forum Antworten für meine Problemstellungen gefunden ohne selbst fragen zu müssen, diesmal konnte ich aber leider noch nicht herausfinden wie ich vorgehen muss.
Bei meinem Problem dreht es sich darum, dass für eine Datei mit über 11.000 Zeilen jede Zeile daraufhin geprüft wird, ob sich in der Spalte "PLZ" mehr als eine Postleitzahl befindet. Falls dies der Fall ist, soll die PLZ ausgeschnitten und in eine neue Zeile darunter eingefügt werden - die übrigen Spalteneinträge sollen der Zeile entsprechen aus welcher die PLZ ausgeschnitten wurde.
Falls mehrere PLZ in einer Zelle sind, soll dieser Vorgang so oft durchgeführt werden bis nur noch eine PLZ übrig bleibt. Die PLZ sind dabei durch ein Komma getrennt, welche optimalerweise nicht mehr vorhanden sind danach.
Ich vermute dies ist nur durch einen VBA-Code möglich, darin bin ich selbst jedoch leider nicht so gut. Ich werde auch selbst weitersuchen und probieren, aber hoffe jemand hat für mein Problem die passende Lösung bereit.
Eine Beispiel-Datei mit 4 Zeilen habe ich angehängt.
Schon mal Vielen Dank und liebe Grüße,
Bastian
https://www.herber.de/bbs/user/121317.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
hier Code:

Option Explicit
Sub test()
AddRows GetIndizes
End Sub
Private Function GetIndizes() As Long()
Dim ws      As Worksheet
Dim n       As Long
Dim i       As Long
Dim lr      As Long
Dim idx()   As Long
Dim tmp     As Variant
Set ws = ThisWorkbook.Sheets(1)
With ws
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
tmp = .Range(.Cells(1, 3), .Cells(lr, 3)).Value
For i = LBound(tmp) To UBound(tmp)
If InStr(1, tmp(i, 1), ",", vbTextCompare) > 0 Then
ReDim Preserve idx(n)
idx(n) = i
n = n + 1
End If
Next i
End With
GetIndizes = idx
End Function
Private Sub AddRows(ByRef indizes() As Long)
Dim ws      As Worksheet
Dim lr      As Long
Dim i       As Long
Dim tmp     As Variant
Dim vData   As Variant
ReDim vData(1 To 5)
Set ws = ThisWorkbook.Sheets(1)
With ws
For i = UBound(indizes) To LBound(indizes) Step -1
tmp = Split(.Cells(indizes(i), 3).Value, ",")
vData(1) = .Cells(indizes(i), 1)
vData(2) = .Cells(indizes(i), 2)
vData(4) = .Cells(indizes(i), 4)
vData(5) = .Cells(indizes(i), 5)
For lr = LBound(tmp) To UBound(tmp)
vData(3) = tmp(lr)
.Cells(indizes(i), 1).EntireRow.Clear
.Range(.Cells(indizes(i), 1), .Cells(indizes(i), 5)).Value = vData
If lr  UBound(tmp) Then
.Cells(indizes(i), 1).EntireRow.Insert
End If
Next lr
Next i
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Bedingtes ausschneiden in neue Zeile mit VBA

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bedingtes ausschneiden in neue Zeile mit VBA

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread