Problem mit For Next Schleife

Hallo zusammen,

ich habe eine Tabelle mit mehreren 100 Zeilen und vielen Spalten.
Ich soll eigentlich 100erte Word Dokumente mit Inhalten per Copy und paste füllen.
Also habe ich mir eine Word Vorlage gebastelt und 3 Felder mit Textmarken bestückt, die auch problemlos aus der Tabelle gespeist werden.

In Spalte D habe ich jedoch Unterpunkte, die ich am Anfang jeder Word Datei schreiben will. Das klappt auch, aber leider immer in die nächste abzuspeichernde Datei mit dem Dateinamen der nächsten Bezeichnung?

Ich habe wohl einen Fehler in der for next Schleife und wäre sehr dankbar, wenn jemand mal über meinen Code blicken könnte. Ich verzweifle langsam, denn ich komme nicht drauf, wo der Fehler liegen könnte.

Hier ein Ausschnitt aus der Tabelle:
A B C D
PPSNummer Bezeichnung Zustaendigkeit AktAA
01.04.15 Kundenbetreuung XXX
1.01.100 Ereignissystem
1.01.200 Kalendersystem

01.05.15 Kasse / Sorten / Edelmetalle ORG
1.05.150 Kassenverkehr
1.02.134 Alte Anweisung


01.06.15 Immobilienvermittling/-vermietung IMM
1.06.150 Immobilienvermittlung

Hier der Code:

Sub VorlageSpeichern()
  
    Dim wrdApp As Object
    Dim wrdDoc As Object
    Dim PPSNummer As String
    Dim Bezeichnung As String
    Dim Zustaendigkeit As String
    Dim Dateiname As String
    Dim Speicherpfad As String
    Dim AktAA As String
   
   
    'Dateipfad zur Word-Vorlage
    Const VorlagePfad As String = "U:\Eigene Dateien\UHB Test\3_UHB-Blanko-Vorlage-Test2.docx"
    Const wrdProperty As Integer = 1
  
    'Ordnerpfad zum Speichern der neuen Dateien
    Speicherpfad = "U:\Eigene Dateien\UHB Test\UHB\"
  
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
   
    
    'Schleife durch die Zeilen in der Tabelle
   ' For i = 2 To ThisWorkbook.Sheets("1. Serie").Range("A" & Rows.Count).End(xlUp).Row
       For i = 2 To 35 'nur 25 Zeilen
      
       
        'Werte auslesen
        AktAA = ThisWorkbook.Sheets("1. Serie").Range("S" & i).Value
        PPSNummer = ThisWorkbook.Sheets("1. Serie").Range("A" & i).Value
        Bezeichnung = ThisWorkbook.Sheets("1. Serie").Range("B" & i).Value
        Zustaendigkeit = ThisWorkbook.Sheets("1. Serie").Range("H" & i).Value
      
        
         'Word Vorlage öffnen
       Set wrdDoc = wrdApp.Documents.Open(VorlagePfad, ReadOnly:=False)
      
       ''Neu:
       Set wrdRange = wrdDoc.Range(0, 0)
      
        
        ' Wenn Zuständigkeit Leer
       
        If Zustaendigkeit = "" Then
       
        'schaue nach, ob es alte AAs gibt
        ' Leerzeilen vermeiden
        If AktAA > "" Then
       
            wrdRange.Text = AktAA
            wrdRange.InsertParagraphAfter
       
         End If
        
         Else
       
        'Word Bookmarks füllen
        wrdDoc.Bookmarks("PPSNummer").Range.Text = PPSNummer
        wrdDoc.Bookmarks("Bezeichnung").Range.Text = Bezeichnung
        wrdDoc.Bookmarks("Zust").Range.Text = Zustaendigkeit
   
                   
    'Dateinamen zusammenstellen
        Dateiname = PPSNummer & " " & Bezeichnung & ".docx"
       
    'Speicherpfad und Dateiname kombinieren
        Dateiname = Speicherpfad & Dateiname
       
        'Dokument unter dem neuen Dateinamen speichern
        wrdDoc.SaveAs2 Filename:=Dateiname, FileFormat:=wdFormatXMLDocument
        wrdDoc.Close True
      
        End If
      
 
      
    Next i
 
 
    'wrdDoc.Close True
    wrdApp.Quit
  
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
  
    MsgBox "Die Word-Vorlage wurde für alle Zeilen gespeichert.", vbInformation
  
End Sub