עזרה | פקודת מאקרו של הוספת כמות הסתבכה לי...

אלף שין

שלום רב
במשך שנים הייתי משתמש בפקודת מאקרו בוורד שתכליתה להוסיף יחידה לכל הספרות במסמך
כלומר כל מקום במסמך שכתוב 8 היא כותבת 9 וכל מקום שכתוב 342 היא כותבת 343
כעת אני מפעיל אותה במחשב עם ווינדוס 11 ואופיס 365 [אולי זה קשור] וזה מוסיף בלולאה אינסופית ספרות למספר הראשון במסמך עד שאני נאלץ לסיים פעולת וורד באמצע.
אבקש את עזרת הציבור לתקן לי את המאקרו דלהלן

Sub add_num()
 
 Dim doc As Document
 Set doc = ActiveDocument
 Dim word As Range
 
 'Increment Numbers
 For Each word In doc.Words
 If IsNumeric(word.Text) Then
 word.Text = word.Text + 1
 End If
 Next word
 
 ' Original code for Macro1
 Selection.WholeStory
 
 ' Additional code from the second macro
 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.Font.Color = wdColorRed
 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
 .MatchWildcards = False
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 Selection.Find.ClearFormatting
 Selection.Find.Font.Color = wdColorRed
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find
 .Text = ""
 .Replacement.Text = "^&^s"
 .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.Font.Color = wdBlack
 Selection.MoveStart unit:=wdStory
 Selection.HomeKey wdStory ' This line moves the cursor to the beginning of the document
 
End Sub

Sub min_num()
 
 Dim doc As Document
 Set doc = ActiveDocument
 Dim word As Range
 
 'Increment Numbers
 For Each word In doc.Words
 If IsNumeric(word.Text) Then
 word.Text = word.Text + 1
 End If
 Next word
 
 ' Original code for Macro1
 Selection.WholeStory
 
 ' Additional code from the second macro
 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.Font.Color = wdColorRed
 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
 .MatchWildcards = False
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 Selection.Find.ClearFormatting
 Selection.Find.Font.Color = wdColorRed
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find
 .Text = ""
 .Replacement.Text = "^&^s"
 .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.Font.Color = wdBlack
 Selection.MoveStart unit:=wdStory
 Selection.HomeKey wdStory ' This line moves the cursor to the beginning of the document
 
End Sub

בינארי חכם

@אלף-שין

גימיני 4

Sub add_num()
    Call ChangeNumbers(1)
End Sub

Sub min_num()
    Call ChangeNumbers(-1)
End Sub

Private Sub ChangeNumbers(ByVal stepVal As Long)
    Dim doc As Document
    Set doc = ActiveDocument
    Dim i As Long
    Dim w As Range
    Dim txt As String
    Dim hasTrailingSpace As Boolean

    Application.ScreenUpdating = False

    ' מעבר מהסוף להתחלה מונע לולאה אינסופית ושיבוש אינדקסים
    For i = doc.Words.Count To 1 Step -1
        Set w = doc.Words(i)
        txt = w.Text
        
        ' בדיקה האם המילה מסתיימת ברווח (וורד מצרף רווח עוקב לכל "מילה")
        hasTrailingSpace = (Right(txt, 1) = " ")
        txt = Trim(txt)
        
        ' בדיקה שהטקסט הוא מספר שלם חיובי או שלילי (ללא נקודות או פסיקים שעלולים להשתבש)
        If IsNumeric(txt) And InStr(txt, ".") = 0 And InStr(txt, ",") = 0 Then
            If hasTrailingSpace Then
                w.Text = CStr(CLng(txt) + stepVal) & " "
            Else
                w.Text = CStr(CLng(txt) + stepVal)
            End If
        End If
    Next i

    ' --- המשך הקוד המקורי שלך (צביעה זמנית והוספת רווח קשיח) ---
    Selection.WholeStory
    
    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.Font.Color = wdColorRed
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "^&^s"
        .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.Font.Color = wdBlack
    Selection.HomeKey Unit:=wdStory

    Application.ScreenUpdating = True
End Sub

אלף שין

@בינארי-חכם
ומה הוא מסביר מדוע הישן קורה תקלה של לולאה אינסופית של הוספת ספרה?

בינארי חכם

הסיבה ללולאה האינסופית באופיס 365 היא האופן שבו הלולאה For Each word In doc.Words עובדת בשילוב עם עריכת הטקסט: כאשר משנים את word.Text, אוסף ה-Words במסמך מתעדכן בזמן אמת, מוחק את הרווח העוקב שהיה צמוד למספר, ומגדיר מחדש את הטווח כך שהמאקרו מזהה את המספר החדש שוב ושוב (או מאחד אותו עם המילה הבאה).

בנוסף, במאקרו המקורי שלך הפונקציה השנייה (min_num) הכילה בטעות + 1 במקום - 1.

כדי לפתור את הבעיה לגמרי, יש לעבור על המילים מהסוף להתחלה (לולאת For i = ... Step -1) או להשתמש בחיפוש מבוסס תווים כלליים (Wildcards), ולשמור על הרווח שאחרי המספר במידה והיה קיים.

להלן הקוד המתוקן והמלא (כולל החלק שמוסיף רווח קשיח ^s לאחר המספרים כפי שהיה אצלך בקוד המקורי, ותיקון של פונקציית ההפחתה min_num):