Excel-Makro für Tabellenumformung

Question

Hallo,
ich bin auf der Suche nach einem Makro das meine existierende Tabelle in eine neue Form überträgt. Die aktuelle Tabelle enthält eine Spalte mit Zellen mit Kundennamen untereinander. Diese sollen in einer neuen Tabelle jeweils 12x untereinander geschrieben werden, anschließend soll er die nächste Zelle nehmen und 12x übertragen. Dieses Spiel soll so lange gehen, bis eine leere Zelle erreicht ist.

So ist die Zellenstruktur ab Zelle G3, diese soll in ein neues Blatt jeweils 12x übertragen werden:
Eindeutigkeit
Wolf 84038/000/10
G+H 83959/000/10
G+H 83959/000/50
Schröter 83929/000/10
BEST 84079/000/10

Neu soll es dann so ausschauen:
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
Wolf 84038/000/10
G+H 83959/000/10
G+H 83959/000/10
G+H 83959/000/10
.
.
.
.

Kann mir da vielleicht jemand helfen? Ich bin da mit meinem normalen Excel-Latein leider aufgeschmissen...

Answer 1

Hallo Steffen,

das folgende Makro gehört in ein Standard Modul der betreffenden Arbeitsmappe.

Sub zwoelfmal()

Dim lngLetzte As Long
Dim arrInhalt As Variant
Dim i As Long
Dim z As Long

With ActiveSheet
'letzte Zeile in aktuellem Arbeitsblatt ermitteln
lngLetzte = .Cells(Rows.Count, 7).End(xlUp).Row
'Spalte G ab Zeile 3 in Array einlesen
arrInhalt = .Range(.Cells(3, 7), .Cells(lngLetzte, 7))
End With

'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = "Neue Liste"

'Inhalte ab Zeile 2, Spalte A jeweils 12 mal einfügen
For i = LBound(arrInhalt) To UBound(arrInhalt)
'aber nur, wenn nicht leer, dann Makro beenden
If arrInhalt(i, 1) = "" Then Exit For
For z = 1 To 12
ActiveSheet.Cells(1 + (i - 1) * 12 + z, 1) = arrInhalt(i, 1)
Next z
Next i

End Sub

Das Makro muss aus dem Blatt ausgeführt werden, in dem die Daten stehen, die umgeformt werden sollen.
Die Daten werden in ein neues Blatt in Spalte A ab Zeile 2 eingefügt.

Gruß

M.O.