טיפ בוורד המרה אנגלית - עברית בוורד

[אפר]

במהלך השרשורים בנושאי מאקרו ביקשו מאקרו שהופך עברית ואנגלית מצורף לטובת הציבור
פועל בוורד על הבחירה
בין אנגלית קטן לעברית ולהפך
אשמח להערות

מחליף קטע נבחר בין אנגלית קטנה לעברית ולהיפך

Public Sub EnHeb()
    Const listEn = "qwertyuiopasdfghjkl;'zxcvbnm,./()[]{}"
    Const listHeb = "/'קראטוןםפשדגכעיחלךף,זסבהנמצתץ.)(][}{"
    Dim Status As Long
    Dim i As Long
    Dim Str As String
    Dim Result As String
    Str = Selection
    Do While Status = 0 And Mid(Str, i + 1, 1) <> ""
        If InStr(listEn, Mid(Str, i + 1, 1)) > 0 Then Status = -1
        If InStr(listHeb, Mid(Str, i + 1, 1)) > 0 Then
            If Status = -1 Then Status = 0 Else Status = 2
        Else
            Status = IIf(Status = -1, 1, 0)
        End If
        i = i + 1
    Loop
    For i = 1 To Len(Str)
        If Status = 2 Then
            If Mid(Str, i, 1) = "" Then
            ElseIf InStr(listHeb, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listEn, InStr(listHeb, Mid(Str, i, 1)), 1)
            ElseIf InStr(listEn, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listHeb, InStr(listEn, Mid(Str, i, 1)), 1)
            Else
                Result = Result & Mid(Str, i, 1)
            End If
        Else
            If Mid(Str, i, 1) = "" Then
            ElseIf InStr(listEn, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listHeb, InStr(listEn, Mid(Str, i, 1)), 1)
            ElseIf InStr(listHeb, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listEn, InStr(listHeb, Mid(Str, i, 1)), 1)
            Else
                Result = Result & Mid(Str, i, 1)
            End If
        End If
    Next i
    Selection = Result
End Sub

 

[הללוהו ב ו]

אשמח להערות

א' לפעמים אותיות ראשונות מאנגלית לעברית הוא לא מחליף לעברית רק ממיר אותו לאותיות רשיות.
ב' לפעמים זה גם נוגע לאותיות רשיות אם תוכל להתאימו לזה גם כן כמו שיש בוורד בחיפוש החלף כל המילים הדומות..

 

[הללוהו ב ו]

כדי שיחול על אות ראשונה ג"כ וכן באותיות גדולות אפשר עם הקוד הזה, הבאתי את זה ג"כ כאן במקו"א שדיברו ע"ז ועכשיו אביא אותה כאן תעדכנו אם עובד חלק...

Public Sub EnHeb()
    Const listEn = "qwertyuiopasdfghjkl;'zxcvbnm,./()[]{}"
    Const listHeb = "/'קראטוןםפשדגכעיחלךף,זסבהנמצתץ.)(][}{"
    Dim Status As Long
    Dim i As Long
    Dim Str As String
    Dim Result As String
   Str = LCase(Selection)
    Do While Status = 0 And Mid(Str, i + 1, 1) <> ""
        If InStr(listEn, Mid(Str, i + 1, 1)) > 0 Then Status = -1
        If InStr(listHeb, Mid(Str, i + 1, 1)) > 0 Then
            If Status = -1 Then Status = 0 Else Status = 2
        Else
            Status = IIf(Status = -1, 1, 0)
        End If
        i = i + 1
    Loop
    For i = 1 To Len(Str)
        If Status = 2 Then
            If Mid(Str, i, 1) = "" Then
            ElseIf InStr(listHeb, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listEn, InStr(listHeb, Mid(Str, i, 1)), 1)
            ElseIf InStr(listEn, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listHeb, InStr(listEn, Mid(Str, i, 1)), 1)
            Else
                Result = Result & Mid(Str, i, 1)
            End If
        Else
            If Mid(Str, i, 1) = "" Then
            ElseIf InStr(listEn, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listHeb, InStr(listEn, Mid(Str, i, 1)), 1)
            ElseIf InStr(listHeb, Mid(Str, i, 1)) > 0 Then
                Result = Result & Mid(listEn, InStr(listHeb, Mid(Str, i, 1)), 1)
            Else
                Result = Result & Mid(Str, i, 1)
            End If
        End If
    Next i
    Selection = Result
End Sub