einbau von einer Schleife

Question

ich will über einen vba code in eine excel Arbeitsmappe aus der ersten Tabelle (Adressliste) Daten in mehrere einzelne Blätter (wie das Musterblatt) kopieren. komme aber nich drauf wie ich die Schleife aufstellen soll, sodass so viele neue Blätter erstellt werden bis das bei der Spalte Name keine Daten mehr enthalten sind.

so sieht bisher meine Ausbeute aus:

Sub Neu()


Dim Adressliste

Application.ScreenUpdating = False
Sheets("Adressliste").Select
Range("I2").Select

1: Name = ActiveCell.Value
If Name = 0 Then GoTo Ende

Sheets("Musterblatt").Select
Sheets("Musterblatt").Copy After:=Sheets(2)
Range("D6:F6").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-4]C[5]"
Range("D7:F7").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-5]C[6]"
Range("D8:F8").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-6]C[7]"
Range("D10:F10").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-8]C[8]"
Range("D11:F11").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-9]C[9]"
Range("D12:F12").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-10]C[10]"
Range("D15:F15").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-13]C[12]"
Range("D17:F17").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-15]C[4]"
Range("D18:F18").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-16]C[-2]"
Range("D19:F19").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-17]C[-1]"
Range("D20:F20").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-18]C[3]"
Range("D21:F21").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-19]C[1]"
Range("D25:F25").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-23]C[2]"
Range("M6:M8").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-4]C[-12]"
Range("M10:M12").Select
ActiveCell.FormulaR1C1 = "=Adressliste!R[-8]C[-9]"

ActiveSheet.Name = Range("M10").Value

ActiveCell.FormulaR1C1 = "=Adressliste!R[-4]C[-12]"
GoTo 1:

Ende:

MsgBox "Daten wurden eingefügt!"

Application.ScreenUpdating = True
End Sub

Answer 1

Hallo,

probier mal folgendes Makro, so wie ich es aus deinem Code - ohne Kenntnis des Tabellenaufbaus und nähere Angaben, was wohin kopiert werden soll - verstehe:

Sub daten_kopieren()

Dim zeile As Integer

zeile = 2 'Startzeile

Application.ScreenUpdating = False

While Not IsEmpty(Sheets("Adressliste").Cells(zeile, 9)) 'hier wird geprüft, ob in Spalte I etwas steht
'Musterblatt wird kopiert und nach dem letzten Blatt eingefügt
Sheets("Musterblatt").Copy After:=Sheets(ThisWorkbook.Worksheets.Count)

With Sheets(ThisWorkbook.Worksheets.Count)
.Name = Sheets("Adressliste").Cells(zeile, 4) 'Neues Blatt wird umbenannt
'Verknüpfungen in der neuen Tabelle werden erstellt
.Range("D6").FormulaLocal = "=Adressliste!I" & zeile
.Range("D7").FormulaLocal = "=Adressliste!J" & zeile
.Range("D8").FormulaLocal = "=Adressliste!K" & zeile
.Range("D10").FormulaLocal = "=Adressliste!L" & zeile
.Range("D11").FormulaLocal = "=Adressliste!M" & zeile
.Range("D12").FormulaLocal = "=Adressliste!N" & zeile
.Range("D15").FormulaLocal = "=Adressliste!P" & zeile
.Range("D17").FormulaLocal = "=Adressliste!H" & zeile
.Range("D18").FormulaLocal = "=Adressliste!B" & zeile
.Range("D19").FormulaLocal = "=Adressliste!C" & zeile
.Range("D20").FormulaLocal = "=Adressliste!G" & zeile
.Range("D21").FormulaLocal = "=Adressliste!E" & zeile
.Range("D25").FormulaLocal = "=Adressliste!F" & zeile
.Range("M6").FormulaLocal = "=Adressliste!A" & zeile
.Range("M10").FormulaLocal = "=Adressliste!A" & zeile + 4 'Keine Ahnung ob das so richtig ist

End With

zeile = zeile + 1
Wend

MsgBox "Daten wurden eingefügt!"

Application.ScreenUpdating = True

End Sub

Gruß

M.O.