Function ArtlandG2P(ByVal txt As Variant) As String
    ' =========================================================================
    ' ARTLAND G2P (Grapheme-to-Phoneme) & KÖLNER PHONETIK CODER
    ' =========================================================================
    ' Purpose: Normalizes historical Low German / Artland regional name variants
    '          phonetically and encodes them using the Kölner Phonetik algorithm.
    ' =========================================================================

    ' --- CATEGORY 1: Primary General Preparation ---
    
    ' 1.A. Gracefully handle empty cells, missing values, or error codes
    If IsMissing(txt) Then
        ArtlandG2P = ""
        Exit Function
    End If
    
    Dim sTxt As String
    If TypeName(txt) = "Range" Then
        sTxt = CStr(txt.Value2)
    Else
        sTxt = CStr(txt)
    End If
    
    sTxt = Trim(sTxt)
    If sTxt = "" Or sTxt = "Error 2042" Or sTxt = "#N/A" Then
        ArtlandG2P = ""
        Exit Function
    End If

    ' 1.B. Convert to lowercase for uniform processing
    sTxt = LCase(sTxt)
    
    ' 1.C. Normalize umlauts, digraphs, and long vowels
    sTxt = Replace(sTxt, "ä", "a")
    sTxt = Replace(sTxt, "ë", "e")
    sTxt = Replace(sTxt, "ö", "o")
    sTxt = Replace(sTxt, "ü", "u")
    sTxt = Replace(sTxt, "ÿ", "y")
    
    sTxt = Replace(sTxt, "aa", "a")
    sTxt = Replace(sTxt, "ee", "e")
    sTxt = Replace(sTxt, "oo", "o")
    sTxt = Replace(sTxt, "uu", "u")
    sTxt = Replace(sTxt, "eij", "ei")
    
    ' --- CATEGORY 2: Low German (Niederdeutsch) Sound Corrections ---
    sTxt = Replace(sTxt, "breh", "brede")
    sTxt = Replace(sTxt, "loh", "lohe")
    sTxt = Replace(sTxt, "ultz", "ult")
    sTxt = Replace(sTxt, "dorp", "dorf")
    sTxt = Replace(sTxt, "arre", "arren")
    sTxt = Replace(sTxt, "nieh", "nienh")
    
    ' --- CATEGORY 3: Qu Equivalent Handling ---
    Dim p As Long
    p = InStr(1, sTxt, "qu", vbTextCompare)
    Do While p > 0
        If p > 1 Then
            Dim prevChar As String
            prevChar = Mid(sTxt, p - 1, 1)
            ' If preceding character is a consonant, qu = k. Otherwise = kw.
            If prevChar <> "a" And prevChar <> "e" And prevChar <> "i" And prevChar <> "o" And prevChar <> "u" And prevChar <> "y" Then
                sTxt = Left(sTxt, p - 1) & "k" & Mid(sTxt, p + 2)
            Else
                sTxt = Left(sTxt, p - 1) & "kw" & Mid(sTxt, p + 2)
            End If
        Else
            ' Located at the start of the word (e.g., Q...) -> kw
            sTxt = "kw" & Mid(sTxt, 3)
        End If
        p = InStr(p + 1, sTxt, "qu", vbTextCompare)
    Loop
    
    ' --- CATEGORY 4: Längungs-h Conversion (Lengthening h to double vowels, unless whitelisted) ---
    Dim skipH As Boolean
    skipH = False
    If Right(sTxt, 4) = "horn" Or Right(sTxt, 4) = "haus" Or Right(sTxt, 3) = "hus" Or Right(sTxt, 4) = "hues" Then
        skipH = True
    End If
    
    If Not skipH Then
        sTxt = Replace(sTxt, "ah", "a")
        sTxt = Replace(sTxt, "eh", "e")
        sTxt = Replace(sTxt, "oh", "o")
        sTxt = Replace(sTxt, "uh", "u")
    End If
    
    ' --- CATEGORY 5: Z and Sharp S (ß) Normalization ---
    sTxt = Replace(sTxt, "nz", "ntz") ' e.g., Renze
    sTxt = Replace(sTxt, "sz", "s")
    sTxt = Replace(sTxt, "tz", "ts")
    sTxt = Replace(sTxt, "ß", "ss")
    sTxt = Replace(sTxt, "z", "s")
    
    ' --- CATEGORY 6: Consonant Cluster Normalization ---
    sTxt = Replace(sTxt, "ck", "k")
    sTxt = Replace(sTxt, "scha", "sga")
    sTxt = Replace(sTxt, "sche", "sge")
    sTxt = Replace(sTxt, "schi", "sgi")
    sTxt = Replace(sTxt, "scho", "sgo")
    sTxt = Replace(sTxt, "schu", "sgu")
    sTxt = Replace(sTxt, "sch", "s")
    sTxt = Replace(sTxt, "ch", "g")
    sTxt = Replace(sTxt, "c", "k")
   
    ' --- CATEGORY 7: Phonetic Cluster Safeguards ---
    
    ' --- CATEGORY 7.A: -n- Sound Normalization (Whitelist Prefix) ---
    Dim whitelistAddN As Variant, stN As Variant
    whitelistAddN = Array("theile")
    
    For Each stN In whitelistAddN
        If Len(sTxt) >= Len(stN) Then
            If Left(sTxt, Len(stN)) = stN Then
                sTxt = stN & "n" & Mid(sTxt, Len(stN) + 1)
                Exit For
            End If
        End If
    Next stN
    
    ' --- CATEGORY 7.B: -d- Sound Normalization & -nd- Stem Adjustments ---
    Dim whitelistAddD As Variant, stD As Variant
    whitelistAddD = Array("lan")
    
    For Each stD In whitelistAddD
        If Len(sTxt) >= Len(stD) Then
            If Left(sTxt, Len(stD)) = stD Then
                sTxt = stD & "d" & Mid(sTxt, Len(stD) + 1)
                Exit For
            End If
        End If
    Next stD
    
    ' Specific corrections on -nd- combinations
    If Left(sTxt, 5) = "landg" Then
        sTxt = "lang" & Right(sTxt, Len(sTxt) - 5)
    ElseIf Left(sTxt, 5) = "lande" Then
        sTxt = "lane" & Right(sTxt, Len(sTxt) - 5)
    ElseIf Left(sTxt, 5) = "landd" Then
        sTxt = "land" & Right(sTxt, Len(sTxt) - 5)
    End If
    
    ' --- CATEGORY 7.C: -e- Insertion & Cluster Normalization ---
    sTxt = Replace(sTxt, "dk", "dek")
    sTxt = Replace(sTxt, "dtk", "dtek")
    sTxt = Replace(sTxt, "dc", "dek")
    sTxt = Replace(sTxt, "ln", "len")
    sTxt = Replace(sTxt, "lm", "lem")
    sTxt = Replace(sTxt, "rnk", "renk")
    sTxt = Replace(sTxt, "rn", "ren")
    sTxt = Replace(sTxt, "tr", "ter")
    sTxt = Replace(sTxt, "norst", "nhorst")
    sTxt = Replace(sTxt, "nost", "nhorst")
    
    If Right(sTxt, 4) = "unke" Then
        sTxt = Left(sTxt, Len(sTxt) - 4) & "unneke"
    End If
        
    ' --- CATEGORY 8: Y Handling ---
    sTxt = Replace(sTxt, "ay", "ai")
    sTxt = Replace(sTxt, "ey", "ei")
    sTxt = Replace(sTxt, "oy", "oi")
    sTxt = Replace(sTxt, "uy", "ui")
    sTxt = Replace(sTxt, "wy", "wi")
    sTxt = Replace(sTxt, "y", "i")
    
    ' --- CATEGORY 9: Labial Shift (v -> f) ---
    sTxt = Replace(sTxt, "v", "f")
    
    ' --- CATEGORY 10: Dental Cluster Simplification (dt -> t) ---
    sTxt = Replace(sTxt, "dt", "t")
    
    ' --- CATEGORY 11: Double Consonant Reduction & Stem Mapping ---
    
    ' --- CATEGORY 11.A: Specific -nn- to -nd- Normalization for Stems ---
    Dim transformNnToNd As Boolean: transformNnToNd = False
    Dim matchedW As String: matchedW = ""
    Dim whitelistNn As Variant, w As Variant
    whitelistNn = Array("bronner", "brunner", "linne", "hunner", "senne")
    
    For Each w In whitelistNn
        If Len(sTxt) >= Len(w) Then
            If Left(sTxt, Len(w)) = w Then
                transformNnToNd = True
                matchedW = w
                Exit For
            End If
        End If
    Next w
    
    If transformNnToNd Then
        Dim fixedStem As String
        fixedStem = Replace(matchedW, "nn", "nd")
        sTxt = fixedStem & Mid(sTxt, Len(matchedW) + 1)
    End If
   
    ' --- CATEGORY 11.B: Specific -ll- to -ld- Normalization for Stems ---
    Dim transformLlToLd As Boolean: transformLlToLd = False
    Dim whitelistLl As Variant, wl As Variant
    whitelistLl = Array("hille")
    
    For Each wl In whitelistLl
        If Len(sTxt) >= Len(wl) Then
            If Left(sTxt, Len(wl)) = wl Then
                transformLlToLd = True
                Exit For
            End If
        End If
    Next wl
    
    If transformLlToLd Then
        sTxt = Replace(sTxt, "ll", "ld")
    End If
    
    ' --- CATEGORY 11.C: Standard Double Consonant Reduction ---
    Dim dubbel As Variant, d As Variant
    dubbel = Array("bb", "cc", "dd", "ff", "gg", "hh", "jj", "kk", "ll", "mm", "nn", "pp", "qq", "rr", "ss", "tt", "vv", "ww", "xx", "zz")
    
    For Each d In dubbel
        sTxt = Replace(sTxt, d, Left(d, 1))
    Next d
    
    ' --- CATEGORY 12: Auslaut (Word-End) Normalization ---
    
    ' --- CATEGORY 12.A: Auslaut Protection Whitelist ---
    Dim beschermd As Boolean: beschermd = False
    Dim uiz As Variant, u As Variant
    uiz = Array("haus", "hus", "hues", "horn", "horst", "dos", "tos", "vos", "haase", "kus")
    For Each u In uiz
        If Right(sTxt, Len(u)) = u Then
            beschermd = True
            Exit For
        End If
    Next u
    
    ' --- CATEGORY 12.B: Terminal Stripping and Suffix Standardization ---
    If Not beschermd Then
        
        If Right(sTxt, 3) = "des" Then
            sTxt = Left(sTxt, Len(sTxt) - 2) & "en"
        ElseIf Right(sTxt, 3) = "nes" Then
            sTxt = Left(sTxt, Len(sTxt) - 3) & "ne"
        ElseIf Right(sTxt, 4) = "ener" Then
            sTxt = Left(sTxt, Len(sTxt) - 4)
        ElseIf Right(sTxt, 3) = "rth" Then
            sTxt = Left(sTxt, Len(sTxt) - 1)
        End If
        
        Do While Right(sTxt, 1) = "s"
            sTxt = Left(sTxt, Len(sTxt) - 1)
        Loop
        
        If Right(sTxt, 2) = "er" Then
            sTxt = Left(sTxt, Len(sTxt) - 2) & "er"
        ElseIf Right(sTxt, 5) = "ersge" Then
            sTxt = Left(sTxt, Len(sTxt) - 3)
        ElseIf Right(sTxt, 3) = "ngk" Then
            sTxt = Left(sTxt, Len(sTxt) - 3) & "ng"
        ElseIf Right(sTxt, 4) = "lert" Then
            sTxt = Left(sTxt, Len(sTxt) - 1)
        ElseIf Right(sTxt, 4) = "bert" Then
            sTxt = Left(sTxt, Len(sTxt) - 1)
        ElseIf Right(sTxt, 4) = "ring" Then
            sTxt = Left(sTxt, Len(sTxt) - 4) & "rding"
        ElseIf Right(sTxt, 1) = "k" And Len(sTxt) >= 2 Then
            Dim vorigTeken As String
            vorigTeken = Mid(sTxt, Len(sTxt) - 1, 1)
            If vorigTeken = "a" Or vorigTeken = "e" Or vorigTeken = "i" Or vorigTeken = "o" Or vorigTeken = "u" Or vorigTeken = "y" Then
                sTxt = sTxt & "en"
            End If
        ElseIf Right(sTxt, 1) = "e" Then
            sTxt = Left(sTxt, Len(sTxt) - 1) & "en"
        End If

        ' --- CATEGORY 12.C: Direct -ing to -mann Conversions ---
        Select Case sTxt
            Case "rosing": sTxt = "rosman"
            Case "jelsing": sTxt = "jelman"
            Case "laging": sTxt = "lage"
            Case "mesing": sTxt = "mesen"
        End Select

        ' --- CATEGORY 12.D: Suffix Cleaning (-sche, -ert, -uel, -ul) ---
        If Right(sTxt, 4) = "sche" And Len(sTxt) > 4 Then
            Dim vorigTekens As String
            vorigTekens = Mid(sTxt, Len(sTxt) - 4, 1)
            If vorigTekens <> "a" And vorigTekens <> "e" And vorigTekens <> "i" And vorigTekens <> "o" And vorigTekens <> "u" And vorigTekens <> "y" Then
                sTxt = Left(sTxt, Len(sTxt) - 4)
            End If
        End If
        
        If Right(sTxt, 4) = "bert" Or Right(sTxt, 4) = "hert" Or Right(sTxt, 4) = "pert" Then
            ' Leave genuine Germanic names intact
        ElseIf Right(sTxt, 3) = "ert" Then
            sTxt = Left(sTxt, Len(sTxt) - 1)
        ElseIf Right(sTxt, 3) = "uel" Then
            sTxt = Left(sTxt, Len(sTxt) - 3) & "en" ' Corrected string slicing bug
        ElseIf Right(sTxt, 2) = "ul" Then
            sTxt = Left(sTxt, Len(sTxt) - 2) & "en" ' Corrected string slicing bug
        End If
        
        If Right(sTxt, 1) = "h" And Not (Right(sTxt, 2) = "ch") Then
            sTxt = Left(sTxt, Len(sTxt) - 1)
        End If
        
    End If
    
    If Right(sTxt, 1) = "d" Then
        sTxt = Left(sTxt, Len(sTxt) - 1) & "t"
    End If
    
    ' --- CATEGORY 13: MPF Sounds in Inlaut ---
    sTxt = Replace(sTxt, "mpf", "mp")
    
    ' --- KÖLNER PHONETIK CODERING ---
    Dim resCode As String: resCode = ""
    Dim i As Long, lChar As String
    
    For i = 1 To Len(sTxt)
        lChar = Mid(sTxt, i, 1)
        Select Case lChar
            Case "b", "p": resCode = resCode & "1"
            Case "d", "t": resCode = resCode & "2"
            Case "f", "w": resCode = resCode & "3"
            Case "g", "k", "q": resCode = resCode & "4"
            Case "l": resCode = resCode & "6"
            Case "m", "n": resCode = resCode & "7"
            Case "r": resCode = resCode & "8"
            Case "s", "z": resCode = resCode & "9"
            Case "i", "e", "a", "y": resCode = resCode & "0"
            Case "u", "o": resCode = resCode & "A"
        End Select
    Next i
    
    If Len(resCode) > 0 Then
        resCode = UCase(Left(sTxt, 1)) & Mid(resCode, 2)
    End If
    
    Do While InStr(resCode, "00") > 0
        resCode = Replace(resCode, "00", "0")
    Loop
    
    If Len(resCode) >= 2 Then
        Dim firstLet As String
        firstLet = LCase(Left(resCode, 1))
        If (firstLet = "a" Or firstLet = "e" Or firstLet = "i" Or firstLet = "o" Or firstLet = "u" Or firstLet = "y") Then
            If Mid(resCode, 2, 1) = "0" Then
                resCode = Left(resCode, 1) & Mid(resCode, 3)
            End If
        End If
    End If
    
    ArtlandG2P = resCode
End Function
