Fortlaufende Nummer nachträglich anfügen

Sub Plan()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Long, tempZeile As Long
Dim strMark As String
Set WS1 = Worksheets("Fragen")
Set WS2 = Worksheets("Plan")
Application.ScreenUpdating = False
For iZeile = WS1.Cells(WS1.Rows.Count, 3).End(xlUp).Row To 5 Step -1
If IsNumeric(WS1.Cells(iZeile, 3)) And WS1.Cells(iZeile, 3)  "" Then
Select Case WS1.Cells(iZeile, 3)
Case 6 To 8: strMark = "Bemerkung"
Case 4: strMark = "Bemerkung"
Case 0 To 2: strMark = "Bemerkung"
Case Else: strMark = ""
End Select
If strMark  "" Then
tempZeile = Application.Match(strMark, WS2.Columns(6), 0) + 1
WS2.Rows(tempZeile).Insert Shift:=xlDown
WS2.Cells(tempZeile, 5) = WS1.Cells(iZeile, 1)
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, 4)
WS2.Cells(tempZeile, 7) = WS1.Cells(iZeile, 3)
WS2.Cells(tempZeile, 2) = Worksheets("Deckblatt").Range("F7").Value
WS2.Cells(tempZeile, 8) = Worksheets("Deckblatt").Range("F11").Value
WS2.Cells(tempZeile, 3) = Worksheets("Deckblatt").Range("F12").Value
WS2.Cells(tempZeile, 1) = Worksheets("Deckblatt").Range("F6").Value
WS2.Cells(tempZeile, 4) = "S"
Call ZeileFormatieren1(tempZeile, WS2)
End If
End If
Next iZeile
End Sub
Private Sub ZeileFormatieren1(Zeile As Long, WS As Worksheet)
With WS.Range(WS.Cells(Zeile, 1), WS.Cells(Zeile, 16))
.Interior.Pattern = xlNone
.Font.Bold = False
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.WrapText = True
.Rows.EntireRow.AutoFit
End With
Dim Zelle As Range
Set Zelle = Columns(7).Find(what:="0")
If Not Zelle Is Nothing Then Zelle.Offset(0, 0).Value = "A"
Set Zelle = Columns(7).Find(what:="4")
If Not Zelle Is Nothing Then Zelle.Offset(0, 0).Value = "A"
Set Zelle = Columns(7).Find(what:="6")
If Not Zelle Is Nothing Then Zelle.Offset(0, 0).Value = "F"
Set Zelle = Columns(7).Find(what:="8")
If Not Zelle Is Nothing Then Zelle.Offset(0, 0).Value = "V"
i = 1
Set Zelle = Columns(1).Find(Worksheets("Deckblatt").Range("F6"))
If Not Zelle Is Nothing Then Zelle.Offset(0, 0).Value = Worksheets("Deckblatt").Range("F6") & "- _
" & i
i = i + 1
End Sub