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

[יאיר דניאל]

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

מאקרו חזרה מהערה לטקסט:

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

Sub חזרה_מהערה_לטקסט()
'
' חזרה_מהערה_לטקסט Macro
'
'
    If ActiveWindow.ActivePane.View.Type = wdPrintView Or ActiveWindow. _
        ActivePane.View.Type = wdWebView Or ActiveWindow.ActivePane.View.Type = _
        wdPrintPreview Then
        ActiveWindow.View.SeekView = wdSeekMainDocument
    Else
        ActiveWindow.Panes(2).Close
    End If
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    ActiveWindow.ActivePane.SmallScroll Down:=5
End Sub

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

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

Sub מעבר_להערה()
'
' מעבר_להערה Macro
'
'
    If ActiveWindow.ActivePane.View.Type = wdPrintView Or ActiveWindow. _
        ActivePane.View.Type = wdWebView Or ActiveWindow.ActivePane.View.Type = _
        wdPrintPreview Then
        ActiveWindow.View.SeekView = wdSeekFootnotes
    Else
        ActiveWindow.View.SplitSpecial = wdPaneFootnotes
    End If
    Selection.MoveRight Unit:=wdCharacter, Count:=2
End Sub

[יאיר דניאל]

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