Bedingtes ausschneiden in neue Zeile mit VBA

Forumthread: Bedingtes ausschneiden in neue Zeile mit VBA

27.04.2018 09:57:15

Bastian

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

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bedingtes ausschneiden in neue Zeile mit VBA

27.04.2018 10:20:26

Peter(silie)
AW: Bedingtes ausschneiden in neue Zeile mit VBA

27.04.2018 12:01:39

Bastian

AW: Bedingtes ausschneiden in neue Zeile mit VBA

27.04.2018 10:20:26

Peter(silie)

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

AW: Bedingtes ausschneiden in neue Zeile mit VBA

27.04.2018 12:01:39

Bastian

Hallo Peter,
Vielen Dank für die Antwort. Funktioniert perfekt! Klasse :)
Gruß

Beliebteste Forumthreads (12 Monate)

Bedingtes ausschneiden in neue Zeile mit VBA

Forumthread: Bedingtes ausschneiden in neue Zeile mit VBA

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

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread