שיתוף | המשך - "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.

[יאיר דניאל]

3 מאקרואים להערות שוליים:

בהמשך להנ"ל אני משתף עוד שלושה מאקרואים - להצגת הערות שוליים.
(הבהרה חשובה: לא אני כתבתי את המאקרואים האלו - זה נכתב ע"י @שלמה11 בעקבות הבקשה שלי כאן וכאן)

מי שעובר על מה שהוא כתב, ויש הערת שוליים - צריך לגרור את העכבר ולרחף מעל מספר ההערה בכדי לראות את הכיתוב בהערה.

מאקרו מציג תוכן הערות

המאקרו הזה - עונה על הצורך זהה בצורה הכי טובה, בלחיצה על הקיצור מקשים עולה ההערה למספר שניות (-ניתן להגדיר כמה שניות).
זה נראה כך:

אז הנה המאקרו:

Sub מציג_תוכן_הערות()
    
    Dim rng As Range
    Set rng = Selection.Range
    rng.MoveStart wdCharacter, -1
    rng.MoveEnd wdCharacter, 1
        
    If rng.Footnotes.Count > 0 Then
        With UserForm1
            .Label1.Caption = rng.Footnotes(1).Range.Text
            .Label1.AutoSize = True
            .Label1.Width = 190
            .Height = .Label1.Height + 80
            .Show vbModeless
        End With
        On Error Resume Next
        Application.OnTime Now + TimeValue("00:00:04"), "ת"
        On Error GoTo 0
    End If
        
End Sub
Sub מציג_תוכן_הערות()
    Unload UserForm1
End Sub

בכדי שזה יעבוד - אתם צריכים לייבא לuserform את הקובץ הבא:
UserForm1.frm
הגדירו קיצור מקשים נוח - תכוונו עם החיצים שהסמן יעמוד ליד המספר הערת שוליים - או לפני או אחרי - צמוד, לחצו על הקיצור מקשים והערה תעלה.
זה נראה כך:

• שימו לב! בקוד אצלי זה מוגדר ל4 שניות - תוכלו לשנות את זה לפי מה שנוח לכם.

מאקרו מציג תוכן הערה

• מאקרו זה - פחות "משוכלל" מהקודם, ואם תשאלו א"כ למה הבאתי אותו, למה הוא טוב?
  אז ככה: בהערות שוליים ארוכות, לא יספיק לכם מספר שניות לעבור על כל ההערה (חוץ מזה שאתם בלחץ שעוד שנייה זה נסגר...) - במאקרו הזה - בכדי שההערה תיסגר צריך ללחוץ אישור = אנטר. כך ש.. קחו את הזמן שלכם תעברו על ההערה באופן יסודי ובלי לחץ, סיימתם? פשוט לחצו אנטר ותמשיכו הלאה!

הנה המאקרו:

Sub מציג_תוכן_הערה()
'
' מציג_תוכן_הערה Macro
'
'
    Dim rng As Range
    Selection.MoveStart wdCharacter, -1
    Set rng = Selection.Range
    
    If rng.Footnotes.Count > 0 Then
        MsgBox rng.Footnotes(1).Range.Text, vbInformation, "הערת שוליים"
    End If
    Selection.Move wdCharacter, 1
End Sub

וכך זה נראה בפועל:

הערה חשובה - במאקרו הזה - חייבים שהסמן יהיה אחרי מספר ההערה, ולא לפני.

עצה שלי - תגדירו קיצור מקשים - לשני המאקרואים (אצלי זה מוגדר הראשון כ-CTRL+. והשני כ- CTRL+,) זה ישמש אתכם מלא!

מאקרו הצגת כל הערות השוליים שבעמוד הקודם:

אם אתם מעוניינים לראות בלחיצה אחת את כל ההערות שוליים בעמוד - יש את המאקרו הזה - שיצר @אביעד - כאן:

Sub ShowFootnotesFromPreviousPage()
    Dim fn As Footnote
    Dim currPage As Long
    Dim prevPage As Long
    Dim msg As String
    Dim refRange As Range
    
    ' קבל את מספר העמוד הנוכחי
    currPage = Selection.Information(wdActiveEndPageNumber)
    prevPage = currPage - 1
    
    If prevPage < 1 Then
        MsgBox "אין עמוד קודם במסמך.", vbExclamation, "שגיאה"
        Exit Sub
    End If
    
    msg = ""
    
    ' עבור על כל ההערות במסמך
    For Each fn In ActiveDocument.Footnotes
        Set refRange = fn.Reference
        If refRange.Information(wdActiveEndPageNumber) = prevPage Then
            msg = msg & "• " & Trim(fn.Range.Text) & vbCrLf & vbCrLf
        End If
    Next fn
 
    If msg = "" Then
        MsgBox "אין הערות שוליים בעמוד הקודם.", vbInformation, "אין הערות"
    Else
        MsgBox "הערות שוליים בעמוד הקודם:" & vbCrLf & vbCrLf & msg, vbInformation, "הערות בעמוד " & prevPage
    End If
End Sub

[יאיר דניאל]

אם זה מעניין אתכם - תגיבו, ואעלה בל"נ עוד כמה מאקרואים קטנים לשימוש בקיצורי מקשים במקום העכבר

[אביעד]

Spoiler

יישר כח
אממ. לגבי מה שאמרת שם שלא הייתי צריך לפרט -זה לא אישי.. בד''כ יש עוד כאלה שמסתכלים ולא כולם יודעים.. אז אם לא יועיל לא יזיק

[יאיר דניאל]

מאקרו קטן שכתבתי (בעזרת הAI - כי פשוט קצת הסתבכתי לבד...)
לגיבוי של כל ההגדרות האישיות באופיס, כמו תיקוני שגיאות, תבנית נורמל, מילון, פקודות המאקרו ועיצוב הכרטיסיות שלכם.
זהו מאקרו כפול - גיבוי, ושחזור למיקום המקורי.
זה חשוב לגבות מידי פעם, מנסיון...

• התיקייה שתיווצר לאחר הרצת המאקרו - לא שוקלת כמעט כלום, אבל היא תחסוך לכם הרבה עבודה - כשיימחק לכם ההגדרות איכשהו/ תאפסו את המחשב/ תעשו התקנה נקייה/ תקנו מחשב חדש!

מאקרו גיבוי תבנית נורמל:

[זה מאקרו שכתב אי מי מחברי הפורום, אינני זוכר מי כך שאני לא יכול לתת לו את הקרדיט המגיע לו - לגיבוי של תבנית הנורמל

Sub גיבוי_תבנית_נורמל()
    Dim fso As Object
    Dim sourcePath As String
    Dim destPath As String
    Dim fileName As String
    Dim dateTimeStamp As String
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    sourcePath = "C:\Users\ZMB\AppData\Roaming\Microsoft\Templates\"
    destPath =  **הזינו כאן את הנתיב בו תרצו לשמור את התבנית**
    dateTimeStamp = Format(Now, "dd_mm_yy_hh_mm_ss")
    
    fileName = "Normal.dotm"
    
    If Not fso.FolderExists(destPath) Then
        fso.CreateFolder destPath
    End If
    
    If fso.FileExists(sourcePath & fileName) Then
        fso.CopyFile sourcePath & fileName, destPath & Left(fileName, Len(fileName) - 5) & "_" & dateTimeStamp & ".dotm"
        
        MsgBox "הקובץ הועתק בהצלחה ונוסף לתיקיית הגיבוי."
    Else
        MsgBox "הקובץ המקורי אינו קיים."
    End If
    
    Set fso = Nothing
End Sub

מאקרו גיבוי התאמות אישיות:

• מאקרו זה מגבה את הקבצים הבאים:
  מילון אישי
  תיקון שגיאות אוטומטי
  התאמות אישיות בוורד, אקסל, אקסס
  תבנית נורמל

Option Explicit

Sub גיבוי_ושחזור_התאמות_משתמש()

    Dim fso As Object
    Dim user As String
    Dim basePath As String
    Dim פעולה As VbMsgBoxResult
    Dim src As String, dst As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    user = CreateObject("WScript.Network").UserName

    פעולה = MsgBox( _
        "בחר פעולה:" & vbCrLf & _
        "כן = גיבוי" & vbCrLf & _
        "לא = שחזור", _
        vbYesNoCancel + vbQuestion, _
        "Office PRO")

    If פעולה = vbCancel Then Exit Sub

    With Application.FileDialog(4)
        .Title = IIf(פעולה = vbYes, "בחר תיקייה לגיבוי", "בחר תיקיית גיבוי")
        If .Show <> -1 Then Exit Sub
        basePath = .SelectedItems(1)
    End With

    ' ================= UI – Excel =================
    CreateFolderIfMissing fso, basePath & "\UI"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Local\Microsoft\Office\Excel.officeUI"
        dst = basePath & "\UI\Excel.officeUI"
    Else
        src = basePath & "\UI\Excel.officeUI"
        dst = "C:\Users\" & user & "\AppData\Local\Microsoft\Office\Excel.officeUI"
    End If
    CopyFileSafe fso, src, dst

    ' ================= UI – Word =================
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Local\Microsoft\Office\Word.officeUI"
        dst = basePath & "\UI\Word.officeUI"
    Else
        src = basePath & "\UI\Word.officeUI"
        dst = "C:\Users\" & user & "\AppData\Local\Microsoft\Office\Word.officeUI"
    End If
    CopyFileSafe fso, src, dst

    ' ================= Normal.dotm =================
    CreateFolderIfMissing fso, basePath & "\Word"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Templates\Normal.dotm"
        dst = basePath & "\Word\Normal.dotm"
    Else
        src = basePath & "\Word\Normal.dotm"
        dst = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Templates\Normal.dotm"
    End If
    CopyFileSafe fso, src, dst

    ' ================= Office (Roaming) =================
    CreateFolderIfMissing fso, basePath & "\Office"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Office"
        dst = basePath & "\Office"
    Else
        src = basePath & "\Office"
        dst = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Office"
    End If
    CopyFolderSafe fso, src, dst

    ' ================= UProof =================
    CreateFolderIfMissing fso, basePath & "\UProof"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Roaming\Microsoft\UProof"
        dst = basePath & "\UProof"
    Else
        src = basePath & "\UProof"
        dst = "C:\Users\" & user & "\AppData\Roaming\Microsoft\UProof"
    End If
    CopyFolderSafe fso, src, dst

    ' ================= Spelling =================
    CreateFolderIfMissing fso, basePath & "\Spelling"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Spelling"
        dst = basePath & "\Spelling"
    Else
        src = basePath & "\Spelling"
        dst = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Spelling"
    End If
    CopyFolderSafe fso, src, dst

    ' ================= Excel (Roaming) =================
    CreateFolderIfMissing fso, basePath & "\Excel"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Excel"
        dst = basePath & "\Excel"
    Else
        src = basePath & "\Excel"
        dst = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Excel"
    End If
    CopyFolderSafe fso, src, dst

    ' ================= Access =================
    CreateFolderIfMissing fso, basePath & "\Access"
    If פעולה = vbYes Then
        src = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Access"
        dst = basePath & "\Access"
    Else
        src = basePath & "\Access"
        dst = "C:\Users\" & user & "\AppData\Roaming\Microsoft\Access"
    End If
    CopyFolderSafe fso, src, dst

    MsgBox IIf(פעולה = vbYes, _
        "הגיבוי הושלם בהצלחה", _
        "השחזור הושלם בהצלחה"), _
        vbInformation, "Office PRO"

End Sub

' ================= עזר =================
Sub CreateFolderIfMissing(fso As Object, path As String)
    If Not fso.FolderExists(path) Then fso.CreateFolder path
End Sub

Sub CopyFileSafe(fso As Object, src As String, dst As String)
    If fso.FileExists(src) Then
        CreateFolderIfMissing fso, fso.GetParentFolderName(dst)
        On Error Resume Next
        If fso.FileExists(dst) Then fso.DeleteFile dst, True
        fso.CopyFile src, dst, True
        Err.Clear
        On Error GoTo 0
    End If
End Sub

Sub CopyFolderSafe(fso As Object, src As String, dst As String)
    If fso.FolderExists(src) Then
        CreateFolderIfMissing fso, fso.GetParentFolderName(dst)
        fso.CopyFolder src, dst, True
    End If
End Sub

[מניין]

@יאיר-דניאל כתב בשיתוף | המשך - "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:

הנה מאקרו קטן שכתבתי (בעזרת הAI - כי פשוט קצת הסתבכתי לבד...)
לגיבוי של כל ההגדרות האישיות באופיס, כמו תיקוני שגיאות, תבנית נורמל, מילון, פקודות המאקרו ועיצוב הכרטיסיות שלכם.

האם זה שומר גם על כל הכרטיסיות, הקיצורי דרך, והמאקרואים.

[יאיר דניאל]

@מניין כתב בשיתוף | המשך - "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:

האם זה שומר גם על כל הכרטיסיות, הקיצורי דרך, והמאקרואים.

כן, על המאקרואים ודאי - זה נמצא בתוך התבנית נורמל שנשמרת, ושאר הדברים גם אמור להיות לפי הנתיבים שבהם הם נמצאים, מה שכן, כיון שלא ניסתי בפועל, הייתי ממליץ לך לנסות ולראות.
אני אנסה עוד כמה דקות ואעדכן אותך פה

[יאיר דניאל]

מאקרו להקטנת סוגריים עגולות ומרובעות בתוך הטקסט:

(כרגע הוא מוגדר על הקטנת סוגריים מרובעות לגודל 11 ועגולות לגודל 9 - כמובן שתוכלו לשנות את זה כטוב בעינכם).

Sub הקטנת_סוגריים()
'
' הקטנת_סוגריים Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\[*\]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Replacement.Font.SizeBi = 11
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\(*\)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Replacement.Font.SizeBi = 9
        .Replacement.Font.Size = 9
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

לעצלנים שבינינו - מצורף גם אותו המאקרו - להערות שוליים, עם הגדרות גודל יותר קטנות = 7 למרובע, 6 לעגול.
שימו לב! את המאקרו העליון - הפעילו בעוד הסמן עומד בטקסט עצמו, ואת המאקרו התחתון - בעוד הסמן עומד בהערות השוליים.

Sub הקטנת_סוגריים_הערת_שוליים()
'
' הקטנת_סוגריים_הערת_שוליים Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\[*\]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Replacement.Font.SizeBi = 7
     End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\(*\)"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Replacement.Font.SizeBi = 6
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

[יאיר דניאל]

מאקרו לסימון אותיות בתשובות לעיון ההלכה

• למי שנוהג לכתוב בצורת התבנית הבאה:
  
• מה שהמאקרו הזה עושה הוא כך:
  א. מדגיש ומוסיף פס תחתון למספר התשובה.
  ב. מדגיש את מספר האות - בתוך כל תשובה.

Sub סימון_אותיות_עיון_ההלכה()
'
' סימון_אותיות_עיון_ההלכה Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .BoldBi = True
        .Underline = wdUnderlineSingle
    End With
    With Selection.Find
        .Text = "^p^$:"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Replacement.Font.NameBi = "ShefaClassic"
    End With
       Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .BoldBi = True
        .Underline = 0
    End With
    With Selection.Find
        .Text = "(^$) "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Replacement.Font.NameBi = "ShefaClassic"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

הערה קטנה וחשובה:
כעת המאקרו מוגדר להחליף לפונט: ShefaClassic, תוכלו כמובן לשנות זאת לכל פונט העולה על רוחכם - פשוט החליפו את שם הפונט בשורה הזו:

  .Replacement.Font.NameBi = "ShefaClassic"

[יאיר דניאל]

מאקרו שיצרתי לבקשתו של אחד מחברי הפורום - להחלפת גופנים ע"י מאקרו.

גירסה א:

Sub FinalFont_InstantUpdate()
    Dim selectedFont As String
    Dim lastUsedFont As String
    Dim answer As VbMsgBoxResult
    
    ' 1. בחירה מפורשת של הכל אם לא סומן כלום
    If Selection.Start = Selection.End Then
        ActiveDocument.Range.Select
    End If
    
    ' 2. שליפת הגופן האחרון
    lastUsedFont = GetSetting("MyWordMacros", "Settings", "LastFont", "David")
    
    ' 3. שאלה למשתמש
    answer = MsgBox("האם להשתמש בגופן האחרון: " & lastUsedFont & "?" & vbCrLf & _
                    "לחץ 'כן' לביצוע, או 'לא' לבחירה מרשימה.", _
                    vbYesNoCancel + vbQuestion + vbMsgBoxRight + vbMsgBoxRtlReading, "החלפת גופן")
    
    If answer = vbYes Then
        selectedFont = lastUsedFont
    ElseIf answer = vbNo Then
        With Application.Dialogs(wdDialogFormatFont)
            If .Show = -1 Then
                selectedFont = Selection.Font.NameBi
                If selectedFont = "" Or selectedFont = "0" Then selectedFont = Selection.Font.Name
            End If
        End With
        
        If selectedFont <> "" And selectedFont <> "0" Then
            SaveSetting "MyWordMacros", "Settings", "LastFont", selectedFont
        Else
            Selection.Collapse Direction:=wdCollapseStart
            Exit Sub
        End If
    Else
        Selection.Collapse Direction:=wdCollapseStart
        Exit Sub
    End If
    
    ' 4. ביצוע השינוי עם עדכון מסך כפוי
    If selectedFont <> "" Then
        Application.ScreenUpdating = False ' מכבה עדכון כדי להאיץ
        
        On Error Resume Next
        With Selection.Font
            .NameBi = selectedFont 
            .Name = selectedFont   
        End With
        On Error GoTo 0
        
        ' פקודות לרענון מיידי של המסך
        Application.ScreenUpdating = True ' מדליק חזרה ומאלץ רענון
        DoEvents ' משחרר את המערכת לעדכון גרפי
        Application.ScreenRefresh ' רענון סופי של Word
        
        Selection.Collapse Direction:=wdCollapseStart
        Application.StatusBar = "הגופן עודכן ל-" & selectedFont
    End If
End Sub

Spoiler

גירסה ב:

בחירת גופן להחלפה - מתוך רשימה

Sub ReplaceSpecificFont()
    Dim docFonts As New Collection
    Dim targetFont As String
    Dim replacementFont As String
    Dim lastUsedFont As String
    Dim i As Long
    Dim fontChoice As String
    Dim answer As VbMsgBoxResult

    ' 1. סריקת המסמך לזיהוי פונטים קיימים
    On Error Resume Next
    Dim para As Paragraph
    For Each para In ActiveDocument.Paragraphs
        ' הוספת הגופן הרגיל והגופן העברי לאוסף
        If para.Range.Font.Name <> "" Then docFonts.Add para.Range.Font.Name, para.Range.Font.Name
        If para.Range.Font.NameBi <> "" Then docFonts.Add para.Range.Font.NameBi, para.Range.Font.NameBi
    Next para
    On Error GoTo 0

    If docFonts.Count = 0 Then
        MsgBox "לא נמצאו גופנים מזוהים.", vbExclamation
        Exit Sub
    End If

    ' 2. בחירת הגופן להחלפה
    Dim fontList As String
    fontList = "בחר מספר גופן להחלפה:" & vbCrLf
    For i = 1 To docFonts.Count
        fontList = fontList & i & ". " & docFonts(i) & vbCrLf
    Next i

    fontChoice = InputBox(fontList, "חפש והחלף גופן")
    If Not IsNumeric(fontChoice) Then Exit Sub
    i = CInt(fontChoice)
    If i < 1 Or i > docFonts.Count Then Exit Sub
    targetFont = docFonts(i)

    ' 3. בחירת גופן היעד
    lastUsedFont = GetSetting("MyWordMacros", "Settings", "LastFont", "David")
    answer = MsgBox("להחליף את " & targetFont & " ב-" & lastUsedFont & "?" & vbCrLf & _
                    "לחץ 'כן' לאישור, או 'לא' לבחירה מרשימה.", _
                    vbYesNoCancel + vbQuestion + vbMsgBoxRight + vbMsgBoxRtlReading)

    If answer = vbYes Then
        replacementFont = lastUsedFont
    ElseIf answer = vbNo Then
        With Application.Dialogs(wdDialogFormatFont)
            If .Show = -1 Then
                replacementFont = Selection.Font.NameBi
                If replacementFont = "" Or replacementFont = "0" Then replacementFont = Selection.Font.Name
            End If
        End With
    Else
        Exit Sub
    End If

    If replacementFont = "" Or replacementFont = "0" Then Exit Sub
    SaveSetting "MyWordMacros", "Settings", "LastFont", replacementFont

    ' 4. ביצוע ההחלפה (שיטה משופרת)
    Application.ScreenUpdating = False
    
    ' פקודת ההחלפה צריכה לרוץ פעמיים כדי לכסות גם עברית וגם אנגלית בוודאות
    Call ExecuteFontReplace(targetFont, replacementFont, True)  ' עבור עברית
    Call ExecuteFontReplace(targetFont, replacementFont, False) ' עבור אנגלית

    Application.ScreenUpdating = True
    Application.ScreenRefresh
    
    MsgBox "הפעולה הושלמה עבור הגופן: " & targetFont, vbInformation
End Sub

' פונקציית עזר לביצוע ההחלפה בפועל' פונקציית עזר לביצוע ההחלפה בפועל - עם שמות פרמטרים תקינים
Sub ExecuteFontReplace(fTarget As String, fReplace As String, isBi As Boolean)
    Dim r As Range
    Set r = ActiveDocument.Content
    
    r.Find.ClearFormatting
    r.Find.Replacement.ClearFormatting
    
    If isBi Then
        r.Find.Font.NameBi = fTarget
        r.Find.Replacement.Font.NameBi = fReplace
    Else
        r.Find.Font.Name = fTarget
        r.Find.Replacement.Font.Name = fReplace
    End If
    
    ' התיקון הקריטי: FindText במקום Text, ו-ReplaceWith במקום ReplacementText
    r.Find.Execute FindText:="", ReplaceWith:="", _
        Forward:=True, Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceAll
End Sub

זה עובד כך - תמונות בספויילר

Spoiler

גירסה ג:

(כמו גירסה ב' אבל לא צריך להקליד מספר גופן - אלא בוחרים בגופן עצמו - ההמשך אותו דבר).

פשוט להפעיל את הקובץ המצורף
החלפת גופנים.exe

או להכניס את הקובץ המצורף- לתיקיית הטמפלס של אופיס
(הקובץ למעלה - עושה את זה אוטומטית)

החלפת גופנים.dotm

Spoiler

[יאיר דניאל]

מאקרו תיקון סמינים כפולים ושגיאות הקלדה

(פירוט הפעולות שנעשות ע"י המאקרו - בספויילר בסוף ההודעה)

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

הנה הוא, סתם לשם התרשמות:

Sub תיקון_סימנים_כפולים_ועוד()
'
' תיקון_סימנים_כפולים_ועוד Macro
'
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ".."
        .Replacement.Text = "."
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ".{4,}"
        .Replacement.Text = "."
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ",,"
        .Replacement.Text = ","
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "''"
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "''"
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ".?[! ]"
        .Replacement.Text = "@@^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "@@."
        .Replacement.Text = ". "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ",?[! ]"
        .Replacement.Text = "@@^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "@@,"
        .Replacement.Text = ", "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " . "
        .Replacement.Text = ". "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " , "
        .Replacement.Text = ", "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ' "
        .Replacement.Text = "' "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ,"
        .Replacement.Text = ","
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ."
        .Replacement.Text = "."
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ייי"
        .Replacement.Text = "יי"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "םם"
        .Replacement.Text = "ם"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ןן"
        .Replacement.Text = "ן"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ץץ"
        .Replacement.Text = "ץ"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ףף"
        .Replacement.Text = "ף"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ךך"
        .Replacement.Text = "ך"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = wdColorRed
    With Selection.Find
        .Text = " ם"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ן"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ץ"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ף"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ך"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = wdColorRed
    With Selection.Find
    With Selection.Find
        .Text = "ם[א-ת]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ן[א-ת]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ץ[א-ת]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ף[א-ת]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ך[א-ת]"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = wdColorRed
    With Selection.Find
        .Text = " [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = wdColorAutomatic
    With Selection.Find
        .Text = "ן [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ק [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ה [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ף [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ת [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ש [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ג [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "' [א-ת] "
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ן [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ק [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ה [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ף [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ת [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ש [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "ג [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "' [א-ת]^13"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ", ("
        .Replacement.Text = " ("
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ". ["
        .Replacement.Text = " ["
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ", ["
        .Replacement.Text = " ["
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "[ "
        .Replacement.Text = "["
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ]"
        .Replacement.Text = "]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "( "
        .Replacement.Text = "("
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " )"
        .Replacement.Text = ")"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(.)([! ^13]*>)"
        .Replacement.Text = "\1 \2"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "(,)([! ^13]*>)"
        .Replacement.Text = "\1 \2"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "([! ^13'""])([(\[])"
        .Replacement.Text = "\1 \2"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "([)\]])([! ^13.,'""\?\!])"
        .Replacement.Text = "\1 \2"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^$. )"
        .Replacement.Text = "^&@@"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " )@@"
        .Replacement.Text = ")"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ) "
        .Replacement.Text = " ("
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ( "
        .Replacement.Text = ") "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = """""^$"
        .Replacement.Text = "@@^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "@@"""""
        .Replacement.Text = """"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "' ."
        .Replacement.Text = "'."
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "' ,"
        .Replacement.Text = "',"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "' ]"
        .Replacement.Text = "']"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "  "
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = wdColorRed
    With Selection.Find
        .Text = """^$'"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^l ["
        .Replacement.Text = "^l["
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ^l ["
        .Replacement.Text = "^l["
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

ביקשתי מג'מיני - ייעול של הקוד, והנה הוא לפניכם - בתוספת חלונית מידע בסוף הריצה על כמות התיקונים שהמאקרו ביצע.
אשמח להערות והארות עליו, מה ניתן להוסיף ולשפר, ומה לא עובד בו טוב, לא עברתי על הקוד שנוצר בעיון, רק בדקתי שהוא רץ טוב ושהוא באמת מתקן.

Sub תיקון_סימנים_כפולים_ועוד_עם_דיווח()
    ' עצירת רענון המסך למהירות ריצה מקסימלית
    Application.ScreenUpdating = False
    
    ' הגדרת משתנים לספירת השינויים לפי קטגוריות
    Dim cntPunctuation As Long
    Dim cntSpaces As Long
    Dim cntRed As Long
    Dim cntClean As Long
    Dim i As Long
    
    Dim arrFind As Variant, arrRep As Variant
    
    ' --- קטגוריה 1: סימני פיסוק וכפילויות ---
    arrFind = Array("..", ",,", "''", "ייי", "םם", "ןן", "ץץ", "ףף", "ךך")
    arrRep = Array(".", ",", "'", "יי", "ם", "ן", "ץ", "ף", "ך")
    For i = LBound(arrFind) To UBound(arrFind)
        cntPunctuation = cntPunctuation + FastReplaceAndCount(CStr(arrFind(i)), CStr(arrRep(i)), False)
    Next i
    cntPunctuation = cntPunctuation + FastReplaceAndCount(".{4,}", ".", True)
    
    ' --- קטגוריה 2: תיקוני רווחים, סוגריים ומעברים ---
    cntSpaces = cntSpaces + FastReplaceAndCount(".?[! ]", "@@^&", True)
    cntSpaces = cntSpaces + FastReplaceAndCount("@@.", ". ", False)
    cntSpaces = cntSpaces + FastReplaceAndCount(",?[! ]", "@@^&", True)
    cntSpaces = cntSpaces + FastReplaceAndCount("@@,", ", ", False)
    
    arrFind = Array(" . ", " , ", " ' ", " ,", " .", ", (", ". [", ", [", "[ ", " ]", "( ", " )", _
                    " ) ", " ( ", "' .", "' ,", "' ]", "  ", "^p^p", " ^p", "^l [", " ^l [")
    arrRep = Array(". ", ", ", "' ", ",", ".", " (", " [", " [", "[", "]", "(", ")", _
                   " (", ") ", "'.", "',", "']", " ", "^p", "^p", "^l[", "^l[")
    For i = LBound(arrFind) To UBound(arrFind)
        cntSpaces = cntSpaces + FastReplaceAndCount(CStr(arrFind(i)), CStr(arrRep(i)), False)
    Next i
    
    ' הוספת רווחים אחרי נקודה/פסיק וסביב סוגריים באמצעות תווים כלליים
    cntSpaces = cntSpaces + FastReplaceAndCount("(.)([! ^13])", "\1 \2", True)
    cntSpaces = cntSpaces + FastReplaceAndCount("(,)([! ^13])", "\1 \2", True)
    cntSpaces = cntSpaces + FastReplaceAndCount("([! ^13'""])([(\[])", "\1 \2", True)
    cntSpaces = cntSpaces + FastReplaceAndCount("([)\]])([! ^13.,'""\?\!])", "\1 \2", True)
    
    ' טיפול ברווחים כפולים או מיוחדים עם שטרודל
    cntSpaces = cntSpaces + FastReplaceAndCount("^$. )", "^&@@", False)
    cntSpaces = cntSpaces + FastReplaceAndCount(" )@@", ")", False)
    cntSpaces = cntSpaces + FastReplaceAndCount("""""^$", "@@^&", False)
    cntSpaces = cntSpaces + FastReplaceAndCount("@@""""", """", False)

    ' --- קטגוריה 3: אותיות ושגיאות שנצבעו באדום ---
    arrFind = Array(" ם", " ן", " ץ", " ף", " ך", """^$'")
    For i = LBound(arrFind) To UBound(arrFind)
        cntRed = cntRed + FastReplaceAndCount(CStr(arrFind(i)), "^&", False, wdColorRed)
    Next i
    
    arrFind = Array("ם[א-ת]", "ן[א-ת]", "ץ[א-ת]", "ף[א-ת]", "ך[א-ת]", " [א-ת] ", " [א-ת]^13")
    For i = LBound(arrFind) To UBound(arrFind)
        cntRed = cntRed + FastReplaceAndCount(CStr(arrFind(i)), "^&", True, wdColorRed)
    Next i
    
    ' --- קטגוריה 4: תיקוני הדגשות (החזרה לצבע אוטומטי) ---
    arrFind = Array("ן [א-ת] ", "ק [א-ת] ", "ה [א-ת] ", "ף [א-ת] ", "ת [א-ת] ", "ש [א-ת] ", "ג [א-ת] ", "' [א-ת] ", _
                    "ן [א-ת]^13", "ק [א-ת]^13", "ה [א-ת]^13", "ף [א-ת]^13", "ת [א-ת]^13", "ש [א-ת]^13", "ג [א-ת]^13", "' [א-ת]^13")
    For i = LBound(arrFind) To UBound(arrFind)
        cntClean = cntClean + FastReplaceAndCount(CStr(arrFind(i)), "^&", True, wdColorAutomatic)
    Next i
    
    ' --- קטגוריה 5: סנכרון ותיקון עיצוב של סוגריים (Word RTL Bug Fix) ---
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "[\(\)\[\]]"
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
            Dim charFont As String
            charFont = ""
            
            ' מזהה את הגופן של האות שעוקבת מיד לסוגריים
            If Selection.End < ActiveDocument.Content.End Then
                charFont = ActiveDocument.Range(Selection.End, Selection.End + 1).Font.NameBi
            End If
            
            ' אם ריק (סוף מסמך למשל), בודק את האות שלפני
            If charFont = "" And Selection.Start > 0 Then
                charFont = ActiveDocument.Range(Selection.Start - 1, Selection.Start).Font.NameBi
            End If
            
            ' החלת הגופן העברי בחזרה על הסוגריים עצמם
            If charFont <> "" Then
                Selection.Font.Name = charFont
                Selection.Font.NameBi = charFont
                Selection.Font.NameAscii = charFont
                Selection.Font.NameOther = charFont
            End If
            Selection.Collapse wdCollapseEnd
        Loop
    End With

    ' הפעלת רענון המסך בחזרה
    Application.ScreenUpdating = True
    
    ' --- 6. דיווח ---
    Dim msg As String
    Dim totalChanges As Long
    totalChanges = cntPunctuation + cntSpaces + cntRed + cntClean
    
    msg = "הפעולה הושלמה בהצלחה!" & vbCrLf & vbCrLf & _
          "--- פירוט השינויים שבוצעו במסמך ---" & vbCrLf & _
          "* סימני פיסוק וכפילויות שנקו: " & cntPunctuation & vbCrLf & _
          "* תיקוני רווחים, סוגריים ומעברים: " & cntSpaces & vbCrLf & _
          "* שגיאות ואותיות סופיות שנצבעו באדום: " & cntRed & vbCrLf & _
          "* הדגשות שבוטלו (הוחזרו לצבע רגיל): " & cntClean & vbCrLf & _
          "----------------------------------------" & vbCrLf & _
          "סך כל השינויים שבוצעו במסמך: " & totalChanges
          
    MsgBox msg, vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "דו""ח סיום תיקון מסמך"
End Sub

' פונקציית עזר פנימית לספירה ולהחלפה מהירה
Private Function FastReplaceAndCount(ByVal findText As String, ByVal replaceText As String, ByVal isWildcard As Boolean, Optional ByVal repColor As Long = -1) As Long
    Dim c As Long
    c = 0
    
    Selection.HomeKey Unit:=wdStory
    
    ' שלב א: ספירת מופעים
    With Selection.Find
        .ClearFormatting
        .Text = findText
        .MatchWildcards = isWildcard
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            c = c + 1
            Selection.Collapse wdCollapseEnd
        Loop
    End With
    
    ' שלב ב: החלפה
    If c > 0 Then
        Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = findText
            .Replacement.Text = replaceText
            .MatchWildcards = isWildcard
            .Forward = True
            .Wrap = wdFindContinue
            If repColor <> -1 Then .Replacement.Font.Color = repColor
            .Execute Replace:=wdReplaceAll
        End With
    End If
    
    FastReplaceAndCount = c
End Function

Spoiler

1. ניקוי כפילויות של סימני פיסוק ואותיות
   בשלב הראשון, המאקרו עובר על המסמך ומנקה הקלדות כפולות ומיותרות:

נקודות כפולות: מחליף שתי נקודות רצופות (..) בנקודה אחת.

ריבוי נקודות: מחליף רצף של ארבע נקודות או יותר (....) בנקודה אחת (באמצעות זיהוי תבניות חכם).

פסיקים וגרשיים: מחליף פסיק כפול (,,) בפסיק בודד, ושני גרשיים רצופים ('') בגרש בודד.

אותיות סופיות כפולות: מחליף רצפים שגויים של אותיות סופיות (םם, ןן, ץץ, ףף, ךך) באות סופית אחת.

קיצור יודי"ם: מחליף שלושה יודי"ם רצופים (ייי) בשניים (יי).

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

הוספת רווחים חסרים: אם הוקלדה נקודה או פסיק ומיד אחריהם מילה (ללא רווח), המאקרו מפריד ביניהם ומוסיף את הרווח החסר.

הסרת רווחים לפני סימני פיסוק: מתקן שגיאות שבהן הוקלד רווח לפני נקודה, פסיק או גרש (לדוגמה: הופך , ל-, ).

ניקוי רווחים בתוך סוגריים: מוחק רווחים מיותרים שמופיעים מיד לאחר פתיחת סוגריים או רגע לפני סגירתם (הופך ( מילה ) ל-(מילה)).

ריווח חיצוני לסוגריים: מוודא שיש רווח תקני לפני פתיחת סוגריים ואחרי סגירת סוגריים (בתנאי שאין שם סימן פיסוק אחר).

מחיקת רווחים כפולים: סורק את כל המסמך ומצמצם כל רווח כפול לרווח אחד.

סידור אנטרים ומעברי שורה: מחליף שני אנטרים רצופים (פסקאות ריקות) באנטר אחד, ומוחק רווחים מיותרים שהוקלדו בטעות בדיוק לפני אנטר או לפני מעבר שורה ידני (Shift+Enter).

3. איתור שגיאות הקלדה והדגשתן באדום (בקרת איכות)
   המאקרו משמש כעורך לשוני שמתריע על מילים קטועות או שגיאות הקלדה נפוצות על ידי צביעתן באדום:

אות סופית בתחילת מילה: מזהה וצובע אות סופית (ם, ן, ץ, ף, ך) שהוקלדה מיד אחרי רווח.

אות סופית באמצע מילה: מזהה וצובע אות סופית שמיד אחריה הוקלדה אות רגילה (לדוגמה: המילה "שלוםם" תצבע את ה-'ם' הראשונה, או "עכשיןו").

אותיות בודדות וקטועות: מזהה אותיות בודדות שעומדות לבדן (רווח לפני ורווח או אנטר אחרי) וצובע אותן, כדי להתריע על מילה שנקטעה בטעות.

4. החזרת צבע רגיל למקרים לגיטימיים (ניקוי הדגשות)
   מכיוון שהשלב הקודם צובע כל אות בודדת, המאקרו חכם מספיק כדי לעבור שוב ולבטל את הצבע האדום (להחזיר לשחור/אוטומטי) עבור אותיות בודדות שהן תקינות לחלוטין בשפה העברית:

מסיר את הצבע מאותיות הקידומת או מילים בנות אות אחת: ן, ק, ה, ף, ת, ש, ג (למשל ה' הידיעה, ו' החיבור אם הוקלדה בטעות כבודדת, וכד').

מסיר את הצבע מגרש בודד שמגיע אחרי אותיות.

5. סנכרון ותיקון עיצוב סוגריים (טיפול בבאג של Word)
   המאקרו סורק מחדש את כל המסמך ומחפש כל תו של סוגריים עגולים () או מרובעים [].

עבור כל סוגר שהוא מוצא, הוא "מסתכל" על האות העברית שצמודה אליו וקורא את סוג הגופן שלה (למשל: פרנק-ריל, דוד, נרקיסים).

הוא "מכריח" את הסוגריים לקבל בדיוק את אותו הגופן העברי, ובכך מונע את התופעה שבה הסוגריים "קופצים" לעיצוב אנגלי (כמו Arial) ונראים מנותקים, עבים או לא שייכים לטקסט.

[דאנציג]

@יאיר-דניאל
אצלי הקוד החדש נכנס לLOOP אין סופי.

[יאיר דניאל]

@דאנציג איזה גודל קובץ?
כי אצלי עובד מצויין.
אבל שמת לב שיש בו כמה אי דיוקים קטנים.
אם יהיה לי זמן אעבוד על זה בלילה