Neue Blätter mit Zellenname erstellen

Sub Blätter_erstellen()
Sheets("Muster_M").Select
ActiveSheet.Unprotect Password:="x"
Dim Zelle As Range
With Sheets("Vorgabeliste")
For Each Zelle In Range(.Cells(3, 1), .Cells(1, 1).End(xlDown))
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = Zelle.Value
Sheets("Muster_M").Cells.Copy Destination:=ActiveSheet.Cells
Range("A7").Select
ActiveWindow.FreezePanes = True
ActiveWindow.SmallScroll Down:=-6
ActiveSheet.Protect Password:="x"
Next
Sheets("Muster_M").Select
ActiveSheet.Protect Password:="x"
ActiveSheet.Unprotect Password:="x"
Sheets("Vorgabeliste").Select
End With
End Sub

hier werden aus dem Blatt Vorgabeliste neue Blätter (aus Muster_M) erzeugt.
wenn jetzt dazwischen ein Paar Zeilen frei sind funktioniert es nicht mehr.
Kann man das Makro so umschreiben, das es nur die nichtleeren Zellen von A3 bisA77 durchsucht und die Blätter ertsellt.
Danke für eure Hilfe!