[Tasos]

Καλημέρα σε όλους!

Χρήστο θεώρησα καλό να διαγράψω τα μηνύματα μας που δεν έχουν να προσφέρουν και πολλά στους υπόλοιπους.

Τελικά, μετά από αρκετές διορθώσεις (πάντα με τη βοήθεια σου) έχω να προτείνω το
παρακάτω:

Συνάρτηση σε πεδίο Ερωτήματος ή φόρμας:

Transliterate(Nz([Πεδίο];"");Πληθος Χαρακτήρων;"Διαχωριστικός Χαρακτήρας")

Η συνάρτηση VBA:

Option Explicit

Public Const EVChars = "914,915,916,918,924,925,929,913,917,919,921,927,933,937"
Public Const EFChars = "920,922,926,928,931,932,934,935"
Public Const DummyChar = "?"

'Autor: Tassos Filoxenidis - www.ms-office.gr/forum

Public Function Transliterate(ByRef strChars As String, _
                              Optional ByVal strCharslength As Integer, _
                              Optional ByRef AutoCompleteChar As String) As String

    Dim i As Integer, strChar As String, OldCharsLen As Integer, _
        strCharsLen As Integer, SecChar As Integer
        
    If Trim(AutoCompleteChar) = vbNullString Then AutoCompleteChar = DummyChar
    strChars = ReplaceTones(strChars)
    
    OldCharsLen = Len(strChars)

    If strCharslength = 0 Then strCharslength = OldCharsLen
    
    If Len(strChars) < strCharslength Then
        strChars = strChars & String(strCharslength - Len(strChars), AutoCompleteChar)
    End If
    strCharsLen = Len(strChars)

    For i = 1 To strCharsLen
        Select Case AscW(Mid(strChars, i, 1))

        Case 913    'Alpha
            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 933 Then
                    If i + 2 > OldCharsLen Then
                        SecChar = 0
                    Else
                        SecChar = AscW(Mid(strChars, i + 2, 1))
                    End If
                    If InStr(1, EVChars, SecChar) > 0 Then
                        strChar = strChar & "AV"
                        i = i + 1
                    ElseIf InStr(1, EFChars, SecChar) > 0 Or Right(strChars, 1) = SecChar Then
                        strChar = strChar & "AF"
                        i = i + 1
                    Else
                        strChar = strChar & "A"
                    End If
                Else
                    strChar = strChar & "A"
                End If
            Else
                strChar = strChar & "A"
            End If

        Case 914    'Beta
            strChar = strChar & "B"

        Case 915    'Gama
            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 915 Then
                    strChar = strChar & "NG"
                    i = i + 1
                ElseIf AscW(Mid(strChars, i + 1, 1)) = 922 Then
                    strChar = strChar & "GK"
                    i = i + 1
                Else
                    strChar = strChar & "G"
                End If
            Else
                strChar = strChar & "G"
            End If

        Case 916    'Delta
            strChar = strChar & "D"

        Case 917    'Epsilon

            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 933 Then
                    If i + 2 > OldCharsLen Then
                        SecChar = 0
                    Else
                        SecChar = AscW(Mid(strChars, i + 2, 1))
                    End If
                    If InStr(1, EVChars, SecChar) > 0 Then
                        strChar = strChar & "EV"
                        i = i + 1
                    ElseIf InStr(1, EFChars, SecChar) > 0 Or Right(strChars, 1) = SecChar Then
                        strChar = strChar & "EF"
                        i = i + 1
                    Else
                        strChar = strChar & "E"
                    End If

                Else
                    strChar = strChar & "E"
                End If
            Else
                strChar = strChar & "E"
            End If

        Case 918    'Zeta
            strChar = strChar & "Z"

        Case 919    'Eta

            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 933 Then
                    If i + 2 > OldCharsLen Then
                        SecChar = 0
                    Else
                        SecChar = AscW(Mid(strChars, i + 2, 1))
                    End If
                    If InStr(1, EVChars, SecChar) > 0 Then
                        strChar = strChar & "IY"
                        i = i + 1
                    ElseIf InStr(1, EFChars, SecChar) > 0 Or Right(strChars, 1) = SecChar Then
                        strChar = strChar & "IF"
                        i = i + 1
                    Else
                        strChar = strChar & "I"
                    End If
                Else
                    strChar = strChar & "I"
                End If
            Else
                strChar = strChar & "I"
            End If

        Case 920    'Theta
            strChar = strChar & "TH"

        Case 921    'Iota
            strChar = strChar & "I"

        Case 922    'Kappa
            strChar = strChar & "K"

        Case 923    'Lambda
            strChar = strChar & "L"

        Case 924    'Mu
            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 928 Then
                    If i > 1 And i + 1 < OldCharsLen Then
                        strChar = strChar & "MP"
                        i = i + 1

                    Else
                        strChar = strChar & "B"
                        i = i + 1
                    End If
                Else
                    strChar = strChar & "M"
                End If
            Else
                strChar = strChar & "Ì"
            End If

        Case 925    'Nu
            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 932 Then
                    strChar = strChar & "NT"
                    i = i + 1
                Else
                    strChar = strChar & "N"
                End If
            Else
                strChar = strChar & "Í"
            End If

        Case 926    'Xi
            strChar = strChar & "X"

        Case 927    'Omicron
            If i < strCharslength Then
                If AscW(Mid(strChars, i + 1, 1)) = 933 Then
                    strChar = strChar & "OU"
                    i = i + 1
                Else
                    strChar = strChar & "O"
                End If
            Else
                strChar = strChar & "O"
            End If

        Case 928    'Pi
            strChar = strChar & "P"

        Case 929    'Rho
            strChar = strChar & "R"

        Case 931    'Sigma
            strChar = strChar & "S"

        Case 932    'Tau
            strChar = strChar & "T"

        Case 933    'Upsilon
            strChar = strChar & "Y"

        Case 934    'Phi
            strChar = strChar & "F"

        Case 935    'Chi
            strChar = strChar & "CH"
            If Len(strChar) >= strCharslength Then strCharslength = strCharslength + 1
        Case 936    'Psi
            strChar = strChar & "PS"
            If Len(strChar) >= strCharslength Then strCharslength = strCharslength + 1
        Case 937    'Omega
            strChar = strChar & "O"

        Case Else
            strChar = strChar & Mid(strChars, i, 1)
        End Select
        If Len(strChar) >= strCharslength Then
            '            strCharslength = strInitialLength
            Exit For
        End If
    Next
    If AutoCompleteChar <> DummyChar Then
        If Len(strChar) < strCharslength Then
            strChar = strChar & String(strCharslength - Len(strChar), AutoCompleteChar)
        End If
    Else
        strChar = Replace(strChar, DummyChar, vbNullString)
    End If
    Transliterate = strChar
End Function

Function ReplaceTones(strChar As String) As String
    ReplaceTones = UCase$(strChar)
    ReplaceTones = Replace(ReplaceTones, ChrW$(902), ChrW$(913))
    ReplaceTones = Replace(ReplaceTones, ChrW$(904), ChrW$(917))
    ReplaceTones = Replace(ReplaceTones, ChrW$(906), ChrW$(921))
    ReplaceTones = Replace(ReplaceTones, ChrW$(938), ChrW$(921))
    ReplaceTones = Replace(ReplaceTones, ChrW$(905), ChrW$(919))
    ReplaceTones = Replace(ReplaceTones, ChrW$(910), ChrW$(933))
    ReplaceTones = Replace(ReplaceTones, ChrW$(939), ChrW$(933))
    ReplaceTones = Replace(ReplaceTones, ChrW$(908), ChrW$(927))
    ReplaceTones = Replace(ReplaceTones, ChrW$(911), ChrW$(937))
    ReplaceTones = Replace(ReplaceTones, ChrW$(962), ChrW$(931))
End Function

Έτσι θα μπορείς να χρησιμοποιήσεις τη συνάρτηση αυτή για να συγχωνεύσεις ένα ή περισσότερα πεδία δίνοντας τα ορίσματα: Πλήθος Χαρακτήρων και "Διαχωριστικός Χαρακτήρας". Μπορείς και να τα παραλείψεις αν χρειαστεί.

Παράδειγμα σε Πεδίο Ερωτήματος:

UsrName: Transliterate(Nz([sName];"");1) & Transliterate(Nz([Surname];"");5) & "-" & [ID]

Ακόμα και αν η συνάρτηση VBA δεν σε καλύπτει πλήρως, μπορείς με απλές συναρτήσεις σε υπολογισμένα πεδία να τροποποιήσεις το τελικό αποτέλεσμα.


Καλή συνέχεια!

Τάσος