Sub
Aufsplitten()
Const
Überschrift = 4
Const
Beschreibung = 7, Zielgruppe = 8, Kanäle = 9
Const
Risikoklasse = 10, Finanzklasse = 11, Anmerkung = 12
Dim
lzei
As
Long
, r
As
Range, c
As
Range, s
As
Variant
, t
As
Variant
, Spalte
As
Long
lzei = Cells(Rows.Count, 1).
End
(xlUp).Row
Set
r = Range(Cells(Überschrift + 1, Beschreibung - 1), Cells(lzei, Beschreibung - 1))
Cells(Überschrift, Beschreibung) =
"Beschreibung"
Cells(Überschrift, Zielgruppe) =
"Zielgruppe und Kundenanzahl"
Cells(Überschrift, Kanäle) =
"Kanäle"
Cells(Überschrift, Risikoklasse) =
"Risikoklasse"
Cells(Überschrift, Finanzklasse) =
"Finanzklasse"
Cells(Überschrift, Anmerkung) =
"Anmerkung"
Range(Cells(Überschrift, Beschreibung), Cells(Überschrift, Anmerkung)).Font.Bold =
True
With
Range(Cells(Überschrift, Beschreibung), Cells(lzei, Anmerkung))
For
i = 7
To
12
.Borders(i).LineStyle = xlContinuous
Next
i
End
With
For
Each
c
In
r.Cells
Spalte = Beschreibung
s = Split(c, Chr(10))
For
Each
t
In
s
If
Left(t, 1) =
"*"
Then
Select
Case
t
Case
"*Beschreibung*"
Spalte = Beschreibung
Case
"*Zielgruppe und Kundenanzahl*"
Spalte = Zielgruppe
Case
"*Kanäle*"
Spalte = Kanäle
Case
"*Risikoklasse*"
Spalte = Risikoklasse
Case
"*Finanzklasse*"
Spalte = Finanzklasse
Case
"*Anmerkung*"
Spalte = Anmerkung
End
Select
ElseIf
Trim(t) <>
""
Then
If
Cells(c.Row, Spalte) =
""
Then
Cells(c.Row, Spalte) = t
Else
Cells(c.Row, Spalte) = Cells(c.Row, Spalte) & Chr(10) & t
End
If
End
If
Next
t
Next
c
Columns(Beschreibung - 1).Delete
Range(Cells(1, Beschreibung), Cells(Rows.Count, Anmerkung)).EntireColumn.AutoFit
Range(Cells(Überschrift, 1), Cells(lzei, Columns.Count)).EntireRow.AutoFit
End
Sub