Du benötigst zwei Word-Dateien in demselben Ordner wie deine Excel-Datei:

• Template_geburtsbrief.docx (für Geburtstage)
• Template_Jubilare.docx (für Jubiläen)

Gestalte deine Briefe in Word wie gewünscht und füge an den entsprechenden Stellen die Platzhalter (siehe unten) ein, z.B. [[Vorname]].

Damit du Makros nutzen kannst, musst du einmalig die Entwicklertools in Excel einschalten:

1. Klicke in Excel auf Datei > Optionen.
2. Wähle links Menüband anpassen.
3. Setze rechts im Fenster einen Haken bei Entwicklertools.
4. Klicke auf OK.

Jetzt siehst du oben im Menü den Reiter "Entwicklertools".

1. Drücke in Excel die Tastenkombination Alt + F11 (der VBA-Editor öffnet sich).
2. Klicke oben im Menü auf Einfügen > Modul.
3. Kopiere den Code unten (Schritt 5) komplett und füge ihn in das weiße Fenster ein.
4. Schließe das Fenster einfach wieder.
5. Speichere deine Excel-Datei als .xlsm (Excel-Arbeitsmappe mit Makros).

Option Explicit

'========================================================
'  KONFIGURATION (PFADE & BLÄTTER)
'========================================================

' 1. Wo liegen die Word-Vorlagen?
'    Leer lassen ("") = Im gleichen Ordner wie diese Excel-Datei
'    Beispiel: "C:\Vorlagen\"
Private Const TEMPLATE_FOLDER_FIXED As String = "" 

' 2. Wo sollen die fertigen Briefe hin?
'    Leer lassen ("") = Erstellt automatisch Ordner im gleichen Verzeichnis
'    Beispiel: "C:\Fertige_Briefe\"
Private Const OUTPUT_FOLDER_FIXED As String = "" 

' 3. Name des Tabellenblatts mit den Daten
Private Const DATA_SHEET As String = "Report"

'========================================================
'  KONFIGURATION (SPALTEN A=1, B=2 ...)
'========================================================

Private Const COL_PERSONALNUMMER As Long = 1  ' A
Private Const COL_ANREDE1 As Long = 2         ' B
Private Const COL_VORNAME As Long = 3         ' C
Private Const COL_NACHNAME As Long = 4        ' D
Private Const COL_STRASSE As Long = 5         ' E
Private Const COL_PLZ As Long = 6             ' F
Private Const COL_ORT As Long = 7             ' G

' Ergebnis-Spalten (Formeln)
Private Const COL_ANREDE2 As Long = 10        ' J
Private Const COL_JUBILEE As Long = 11        ' K (Formel Jubiläum)
Private Const COL_BIRTHDAY As Long = 12       ' L (Formel Geburtstag)

' Zelle für das Berechnungsjahr
Private Const CELL_YEAR As String = "M1"      

'========================================================
'  MAIN
'========================================================

Public Sub Briefe_Geburtstage_erstellen()
    CreateLettersByType "Template_geburtsbrief.docx", COL_BIRTHDAY, "Geburtstag"
End Sub

Public Sub Briefe_Jubilare_erstellen()
    CreateLettersByType "Template_Jubilare.docx", COL_JUBILEE, "Jubiläum"
End Sub

'========================================================
'  LOGIK
'========================================================

Private Sub CreateLettersByType(ByVal templateFileName As String, ByVal triggerCol As Long, ByVal kind As String)
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim wbPath As String, outPath As String, templatePath As String, tFolder As String
    Dim wdApp As Object, wdDoc As Object
    Dim valTrigger As String
    Dim saveName As String, savePath As String
    Dim stichtag As Date
    Dim currentYear As String
    Dim folderName As String
    Dim fileSuffix As String
    Dim triggerNum As String
    
    ' Variablen für Platzhalter deklarieren
    Dim pn As String, a1 As String, vn As String, nn As String
    Dim str As String, plz As String, ort As String, a2 As String
    Dim runderGeb As String, jubilaeum As String

    On Error GoTo EH
    
    Set ws = ThisWorkbook.Worksheets(DATA_SHEET)
    wbPath = ThisWorkbook.Path
    If Len(wbPath) = 0 Then Err.Raise vbObjectError + 1, , "Bitte Excel erst speichern!"

    ' --- 1. ORDNER FÜR FERTIGE BRIEFE ---
    ' Wir holen uns nur die ZAHLEN aus M1 (falls jemand Text rein schreibt)
    currentYear = GetNumbers(CStr(ws.Range(CELL_YEAR).Value))
    
    ' Fallback: Wenn M1 leer ist oder keine Jahreszahl (4 stellig), nehmen wir das aktuelle Jahr
    If Len(currentYear) <> 4 Then currentYear = Year(Date)

    If kind = "Geburtstag" Then
        folderName = "Geburtstagsbriefe_" & currentYear
    Else
        folderName = "Jubilaeumsbriefe_" & currentYear
    End If
    
    If Len(Trim$(OUTPUT_FOLDER_FIXED)) > 0 Then
        outPath = EnsureTrailingBackslash(OUTPUT_FOLDER_FIXED) & folderName & "\"
    Else
        outPath = EnsureTrailingBackslash(wbPath) & folderName & "\"
    End If
    EnsureFolderExists outPath

    ' --- 2. TEMPLATE PFAD ---
    If Len(Trim$(TEMPLATE_FOLDER_FIXED)) > 0 Then
        tFolder = EnsureTrailingBackslash(TEMPLATE_FOLDER_FIXED)
    Else
        tFolder = EnsureTrailingBackslash(wbPath)
    End If
    
    templatePath = tFolder & templateFileName
    If Dir(templatePath) = "" Then Err.Raise vbObjectError + 2, , "Template nicht gefunden in: " & tFolder & vbCrLf & "Dateiname: " & templateFileName

    ' --- 3. WORD STARTEN ---
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False

    lastRow = ws.Cells(ws.Rows.Count, COL_NACHNAME).End(xlUp).Row

    For r = 2 To lastRow
        valTrigger = Trim$(CStr(ws.Cells(r, triggerCol).Value))
        
        If Len(valTrigger) > 0 Then
            
            Set wdDoc = wdApp.Documents.Add(Template:=templatePath, NewTemplate:=False)
            
            ' Platzhalter auslesen
            pn = Trim$(CStr(ws.Cells(r, COL_PERSONALNUMMER).Value))
            a1 = Trim$(CStr(ws.Cells(r, COL_ANREDE1).Value))
            vn = Trim$(CStr(ws.Cells(r, COL_VORNAME).Value))
            nn = Trim$(CStr(ws.Cells(r, COL_NACHNAME).Value))
            str = Trim$(CStr(ws.Cells(r, COL_STRASSE).Value))
            plz = Trim$(CStr(ws.Cells(r, COL_PLZ).Value))
            ort = Trim$(CStr(ws.Cells(r, COL_ORT).Value))
            a2 = Trim$(CStr(ws.Cells(r, COL_ANREDE2).Value))
            
            ' Extra Variablen
            runderGeb = Trim$(CStr(ws.Cells(r, COL_BIRTHDAY).Value))
            jubilaeum = Trim$(CStr(ws.Cells(r, COL_JUBILEE).Value))
            
            stichtag = Date

            ReplaceAll wdDoc, "[[Personalnummer]]", pn
            ReplaceAll wdDoc, "[[Anrede1]]", a1
            ReplaceAll wdDoc, "[[Vorname]]", vn
            ReplaceAll wdDoc, "[[Nachname]]", nn
            ReplaceAll wdDoc, "[[Straße]]", str
            ReplaceAll wdDoc, "[[PLZ]]", plz
            ReplaceAll wdDoc, "[[Ort]]", ort
            ReplaceAll wdDoc, "[[Anrede2]]", a2
            ReplaceAll wdDoc, "[[Datum]]", Format(stichtag, "dd.mm.yyyy")
            
            ' Neue Platzhalter
            ReplaceAll wdDoc, "[[runderGeb]]", runderGeb
            ReplaceAll wdDoc, "[[Jubiläum]]", jubilaeum

            ' Trigger spezifisch (Dateinamen-Logik)
            If kind = "Geburtstag" Then
                ' Falls [[Geburtstag]] verwendet wurde, auch ersetzen
                ReplaceAll wdDoc, "[[Geburtstag]]", runderGeb
                triggerNum = GetNumbers(runderGeb)
                fileSuffix = "Geburtstagsbrief_" & triggerNum & " Jahre"
            ElseIf kind = "Jubiläum" Then
                 ' Falls [[Jubiläum]] verwendet wurde, auch ersetzen
                 ReplaceAll wdDoc, "[[Jubiläum]]", jubilaeum
                triggerNum = GetNumbers(jubilaeum)
                fileSuffix = "Jubilaeumsbrief_" & triggerNum & " Jahre"
            End If

            ' Speichern
            saveName = SafeFileName(vn) & " " & SafeFileName(nn) & "_" & fileSuffix & ".docx"
            savePath = outPath & saveName
            
            If Dir(savePath) <> "" Then Kill savePath
            wdDoc.SaveAs2 savePath
            wdDoc.Close SaveChanges:=False
            
        End If
    Next r

    wdApp.Quit
    MsgBox "Fertig! Dateien liegen in: " & vbCrLf & outPath, vbInformation
    Exit Sub

EH:
    If Not wdApp Is Nothing Then wdApp.Quit
    MsgBox "Fehler: " & Err.Description, vbCritical
End Sub

Private Sub ReplaceAll(wdDoc, findText, replaceText)
    With wdDoc.Content.Find
        .Text = findText
        .Replacement.Text = replaceText
        .Execute Replace:=2
    End With
End Sub

Private Function EnsureTrailingBackslash(p As String) As String
    If Right$(p, 1) <> "\" Then EnsureTrailingBackslash = p & "\" Else EnsureTrailingBackslash = p
End Function

Private Sub EnsureFolderExists(path As String)
    If Dir(path, vbDirectory) = "" Then MkDir path
End Sub

Private Function SafeFileName(s As String) As String
    Dim c
    For Each c In Array("\", "/", ":", "*", "?", """", "<", ">", "|")
        s = Replace(s, c, "")
    Next
    SafeFileName = Trim$(s)
End Function

Private Function GetNumbers(s As String) As String
    Dim i As Long, ch As String, res As String
    res = ""
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If IsNumeric(ch) Then res = res & ch
    Next i
    GetNumbers = res
End Function