Option Explicit

Sub ExcelTabelleNachWordExportierenOhneLevelDuplikate()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Dim wdApp As Object
    Dim wdDoc As Object

    Dim aktuelleJobfamilie As String
    Dim aktuelleJobcluster As String
    Dim aktuelleJobrolle As String

    Dim letzteJobfamilie As String
    Dim letzteJobcluster As String
    Dim letzteJobrolle As String

    Dim kurzbeschreibung As String
    Dim skill As String
    Dim skillsGesammelt As String
    Dim fortschritt As Double

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row

    Application.ScreenUpdating = False
    Application.StatusBar = "Starte Word-Export..."

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add

    For i = 2 To lastRow

        aktuelleJobrolle = Trim(ws.Cells(i, "F").Value)

        fortschritt = (i - 1) / (lastRow - 1)

        Application.StatusBar = _
            "Export läuft... " & Format(fortschritt, "0%") & _
            " | Zeile " & i & " von " & lastRow & _
            " | Jobrolle: " & aktuelleJobrolle

        DoEvents

        If HatLevelOderRoemischeEndung(aktuelleJobrolle) Then
            GoTo NaechsteZeile
        End If

        aktuelleJobfamilie = Trim(ws.Cells(i, "B").Value)
        aktuelleJobcluster = Trim(ws.Cells(i, "D").Value)
        kurzbeschreibung = Trim(ws.Cells(i, "K").Value)
        skill = Trim(ws.Cells(i, "H").Value)

        If aktuelleJobrolle <> letzteJobrolle And letzteJobrolle <> "" Then
            SchreibeSkills wdDoc, skillsGesammelt
            skillsGesammelt = ""
        End If

        If aktuelleJobfamilie <> letzteJobfamilie Then
            SchreibeAbsatz wdDoc, aktuelleJobfamilie, "Überschrift 1"
            letzteJobfamilie = aktuelleJobfamilie
            letzteJobcluster = ""
            letzteJobrolle = ""
        End If

        If aktuelleJobcluster <> letzteJobcluster Then
            SchreibeAbsatz wdDoc, aktuelleJobcluster, "Überschrift 2"
            letzteJobcluster = aktuelleJobcluster
            letzteJobrolle = ""
        End If

        If aktuelleJobrolle <> letzteJobrolle Then
            SchreibeAbsatz wdDoc, aktuelleJobrolle, "Überschrift 3"

            SchreibeAbsatz wdDoc, "Kurzbeschreibung:", "Standard"
            SchreibeAbsatz wdDoc, kurzbeschreibung, "Standard"
            SchreibeAbsatz wdDoc, "", "Standard"

            letzteJobrolle = aktuelleJobrolle
        End If

        If skill <> "" Then
            If skillsGesammelt = "" Then
                skillsGesammelt = skill
            Else
                skillsGesammelt = skillsGesammelt & ", " & skill
            End If
        End If

NaechsteZeile:
    Next i

    If skillsGesammelt <> "" Then
        SchreibeSkills wdDoc, skillsGesammelt
    End If

    wdDoc.SaveAs2 ThisWorkbook.Path & "\Jobrollen.docx"

    Application.StatusBar = False
    Application.ScreenUpdating = True

    MsgBox "Word-Datei wurde erstellt:" & vbCrLf & _
           ThisWorkbook.Path & "\Jobrollen.docx"

End Sub


Private Function HatLevelOderRoemischeEndung(ByVal text As String) As Boolean

    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")

    With regex
        .Global = False
        .IgnoreCase = True

        .Pattern = "\s+(I|II|III|IV|V|Level\s+[1-5])\s*\(w\s*/\s*m\s*/\s*d\)\s*$"
    End With

    HatLevelOderRoemischeEndung = regex.Test(Trim(text))

End Function


Private Sub SchreibeSkills(ByVal wdDoc As Object, ByVal skillsText As String)

    SchreibeAbsatz wdDoc, "Skills:", "Standard"
    SchreibeAbsatz wdDoc, skillsText, "Standard"
    SchreibeAbsatz wdDoc, "", "Standard"

End Sub


Private Sub SchreibeAbsatz(ByVal wdDoc As Object, ByVal text As String, ByVal formatvorlage As String)

    Dim rng As Object

    Set rng = wdDoc.Content
    rng.Collapse Direction:=0

    rng.InsertAfter text & vbCrLf
    rng.Paragraphs.Last.Range.Style = formatvorlage

End Sub