Sub Liste_Aufdröseln()
Dim shQ As Worksheet
Dim shZ As Worksheet
Dim Ziel As Range
Dim Zelle As Range
Dim Interp As String
Set shQ = ActiveSheet
On Error GoTo NeuesBlatt
Set shZ = Sheets("Liste")
On Error GoTo 0
Set Ziel = shZ.Cells(Rows.Count, 1)
For Each Zelle In shQ.Cells(1, 1).Resize(shQ.Cells(Rows.Count, 1).End(xlUp).Row, 1)
If Left(Zelle.Value, 1) = "*" Then '--- neue Platte
With Ziel.End(xlUp)
.Offset(1, 0) = Interp
.Offset(1, 1) = Zelle.Value
End With
Else
If InStr(Zelle, "(") > 1 Then ' --- neuer interpret
Interp = Zelle.Value
Else 'sonstiger Text
With Ziel.End(xlUp).Offset(0, 1)
.Value = .Value & " " & Zelle.Value
End With
End If
End If
Next
Exit Sub
NeuesBlatt:
Sheets.Add
ActiveSheet.Name = "Liste"
Resume
End Sub
es sind zwar noch ein paar Zinken drin, die du von Hand nachbearbeiten musst, ist aber zumindest mal ein Ansatz.
Außerdem ist die neue Liste so aufgebaut, daß man sie gut weiterbearbeiten kann.
Sorry, aber viel mehr ist meiner Ansicht nach bei der bescheidenen Qualität der Ausgangsdaten nicht drin.
Gruß, Daniel