Code eingefügt mit Syntaxhighlighter 1.16
Option Explicit
Sub Transponse_ColumnA_in_Horizontal_Lines()
Dim i As Integer, Cr As Long, Cc As Integer
Dim StartC As Integer, rowCounter As Long
Cr = ActiveSheet.Cells(65536, 1).End(xlUp).Row
Cc = 1
StartC = 4 'Begin horizontale Anordnung
rowCounter = 2 'Begin Dateneintrag
For i = 2 To Cr
If Left(Cells(i, 1).Value, Len(Cells(i, 1).Value) - 2) = "Name" Then
rowCounter = rowCounter + 1
End If
Select Case Left(Cells(i, 1).Text, Len(Cells(i, 1).Text) - 1)
Case "Unternehmensart"
Cells(rowCounter, StartC) = Cells(i, 2).Text
Case "Name", "Name "
'Hier gibt es ein problem:
'In der Tabelle ist ein zusätzliches Leerzeichen hinter "Name"
'Bei neuen Einträgen wo dies nicht zutrifft muss das entsprechend
'angepasst werden
Cells(rowCounter, StartC + 1) = Cells(i, 2).Text
Case "Adresse"
Cells(rowCounter, StartC + 2) = Cells(i, 2).Text
Case "Ort"
Cells(rowCounter, StartC + 3) = Cells(i, 2).Text
Case "Klassifikation"
Cells(rowCounter, StartC + 4) = Cells(i, 2).Text
Case "Kette"
Cells(rowCounter, StartC + 5) = Cells(i, 2).Text
Case "Telefon"
Cells(rowCounter, StartC + 6) = Cells(i, 2).Text
Case "Fax"
Cells(rowCounter, StartC + 7) = Cells(i, 2).Text
Case "E-mail"
Cells(rowCounter, StartC + 8) = Cells(i, 2).Text
Case "Anzahl Betten"
Cells(rowCounter, StartC + 9) = Cells(i, 2).Text
Case "Einzelkabine"
Cells(rowCounter, StartC + 10) = Cells(i, 2).Text
Case "Doppelkabine"
Cells(rowCounter, StartC + 11) = Cells(i, 2).Text
Case "3-/4-Pers.-Zimmer"
Cells(rowCounter, StartC + 12) = Cells(i, 2).Text
Case "Suiten"
Cells(rowCounter, StartC + 13) = Cells(i, 2).Text
Case "Appartements"
Cells(rowCounter, StartC + 14) = Cells(i, 2).Text
Case "Veranstaltungsräume"
Cells(rowCounter, StartC + 15) = Cells(i, 2).Text
Case "Saalkapazitäten"
Cells(rowCounter, StartC + 16) = Cells(i, 2).Text
End Select
Next i
MsgBox "Alle Daten transponiert"
End Sub