Hallo Tanja,
kopiere das folgende Makro in ein allgemeines Modul deiner Datenbanktabelle.
Sub umstellen()
Dim lngKtoNr As Long
Dim lngLetzte As Long
Dim lngZeile As Long
Dim lngSpalte As Long
Dim d As Integer
Dim arrDaten As Variant
Dim bExists As Boolean
Dim strName As String
'Name für neues Arbeitsblatt festlegen
strName = "Daten neu"
With ActiveSheet
'Letzte Zeile in Spalte A ermitteln
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'Spalten A und B in Array einlesen
arrDaten = .Range("A1:B" & lngLetzte)
End With
'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = strName
'Daten in neues Blatt schreiben
With Worksheets(strName)
'in Spalte A wird die Kontonummer geschrieben
.Range("A1") = "Kontonummer"
'1. Einfügezeile festlegen: Zeile 1
lngZeile = 1
'Array mit eingelesenen Daten durchlaufen
For d = 1 To UBound(arrDaten, 1)
'Marker für Überschrift zurücksetzen
bExists = False
'Prüfen, ob Kontonummer im Feld steht und falls ja, dann Nummer extrahieren und in Tabelle schreiben
If Left$(arrDaten(d, 1), 11) = "Kontonummer" Then
lngZeile = lngZeile + 1 'Zähler für Einfügezeile erhöhen, da neue Daten
lngSpalte = 1
.Cells(lngZeile, 1) = CLng(Right$(arrDaten(d, 1), Len(arrDaten(d, 1)) - 12)) 'nur Kontonummer in Spalte A eintragen
Else
If arrDaten(d, 2) <> "" Then
'Überschriften suchen
lngSpalte = 1
bExists = False
For lngSpalte = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
If .Cells(1, lngSpalte) = arrDaten(d, 1) Then
bExits = True
Exit For
End If
Next lngSpalte
If bExists = True Then
.Cells(lngZeile, lngSpalte) = arrDaten(d, 2)
Else
.Cells(1, lngSpalte) = arrDaten(d, 1)
.Cells(lngZeile, lngSpalte) = arrDaten(d, 2)
End If
End If
End If
Next d
End With
End Sub
Führe das Makro aus deiner 1. Beispieltabelle (Daten stehen in den Spalten A und B) aus.
Die Daten werden in ein neues Arbeitsblatt übertragen (Daten neu).
Gruß
M.O.