Sub Einzelprotokoll_erstellen()
'
' neu Makro
'
Dim Anzahl As Long, lngLRow As Long 'Anzahl als Zählerindex, lngLRow als letzte beschriebene Zeile
Dim wksEin As Worksheet, wksPlan As Worksheet, wksNeu As Worksheet 'Variablen für die Worksheets
'Worksheets den Variablen zuteilen
Set wksEin = ThisWorkbook.Worksheets("Prüfprotokoll")
Set wksPlan = ThisWorkbook.Worksheets("Vorlage")
'letzte beschriebene Zeile in Tabellenblatt("Prüfprotokoll")
lngLRow = wksEin.Cells(wksEin.Rows.Count, 2).End(xlUp).Row
For Anzahl = 8 To lngLRow
'neues Tabellenblatt erstellen und umbennen
Set wksNeu = Sheets.Add(after:=Sheets(Sheets.Count))
wksNeu.Name = wksEin.Range("C" & Anzahl).Text
'Übernehmen der Vorlage
wksPlan.Rows("1:39").Copy 'Kopieren
wksNeu.Paste Destination:=wksNeu.Range("A1") 'Einfügen
Application.CutCopyMode = False 'Selection-Rahmen entfernen
'füllen der Zellen im neuen Tabellenblatt
wksNeu.Cells(5, 3) = wksEin.Cells(Anzahl, 2)
wksNeu.Cells(6, 3) = wksEin.Cells(Anzahl, 3)
wksNeu.Cells(8, 3) = wksEin.Cells(Anzahl, 4)
wksNeu.Cells(8, 4) = wksEin.Cells(Anzahl, 5)
wksNeu.Cells(8, 5) = wksEin.Cells(Anzahl, 6)
wksNeu.Cells(5, 8) = wksEin.Cells(Anzahl, 7)
wksNeu.Cells(23, 13) = wksEin.Cells(Anzahl, 8)
wksNeu.Cells(24, 13) = wksEin.Cells(Anzahl, 9)
wksNeu.Cells(25, 13) = wksEin.Cells(Anzahl, 10)
wksNeu.Cells(26, 13) = wksEin.Cells(Anzahl, 11)
wksNeu.Cells(29, 13) = wksEin.Cells(Anzahl, 12)
wksNeu.Cells(30, 13) = wksEin.Cells(Anzahl, 13)
Next Anzahl
End Sub