Zelleinhalt aufteilen und Zeile kopieren
02.02.2024 11:57:14
Agt_Romanoff
ich habe eine Excel in der steht in der ersten Spalte ein Firmennamen. In den weiteren Spalten stehen dann unter anderem Branche, Firmenart etc. In einer Spalte stehen aber die Namen der Niederlassunge mit Semikon getrennt. Ich würde diese eine Zelle/Spalte gerne in einzelne Zeilen aufteilen lassen. Ungefähr so:
Firma 1 | Holz | Gmbh | Standort1; Standort2; Standort3
Firma 2 | Metall | Ltd | Standort1; Standort2; Standort3
Firma 3 | Medizin | AG | Standort1; Standort2
Aussehen soll das dann mal so:
Firma 1 | Holz | Gmbh | Standort1
Firma 1 | Holz | Gmbh | Standort2
Firma 1 | Holz | Gmbh | Standort3
Firma 2 | Metall | Ltd | Standort1
Firma 2 | Metall | Ltd | Standort2
Firma 2 | Metall | Ltd | Standort3
Firma 3 | Medizin | AG | Standort1
Firma 3 | Medizin | AG | Standort2
Ich habe hierzu auch schon den folgenden Code gefunden der mit das ganze auf einzelne Zellen untereinander aufteilt, aber da müsste halt noch rein, dass er nicht überschreibt, wenn bereits was drin steht, sondern eine neue Zeile kopiert+einfügt.
Sub SplitAll()
Dim xRg As Range
Dim xRg1 As Range
Dim xCell As Range
Dim I As Long
Dim xAddress As String
Dim xUpdate As Boolean
Dim xRet As Variant
On Error Resume Next
xAddress = Application.ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select a range", "Kutools for Excel", xAddress, , , , , 8)
Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count > 1 Then
MsgBox "You can't select multiple columns", , "Kutools for Excel"
Exit Sub
End If
Set xRg1 = Application.InputBox("Split to (single cell):", "Kutools for Excel", , , , , , 8)
Set xRg1 = xRg1.Range("A1")
If xRg1 Is Nothing Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each xCell In xRg
xRet = Split(xCell.Value, ";")
xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
I = I + UBound(xRet, 1) + 1
Next
Application.ScreenUpdating = xUpdate
End SubVielleicht kann mir jemand helfen und die mir zeigen was ich einfügen muss.
Danke.
MfG Romanoff