ماكرو لاختبار أي رقمين بينهما فاصلة يكون التالي أصغر من سابقه أو مساويه

[أبو عاصم المصري]

احتجت إلى عمل ماكرو يحدد الأرقام المتوالية بشكل خاطئ، بحيث يأتي مثلا (151) بعد (150)، أو يتكرر رقم (151) لكن بشرط أن يكون بين الرقمين فاصلة (،) وهذا يحدث كثيرا في الفهارس، فعملت هذا الماكرو ليقوم بتظليل أي رقم وقع في موضع الخطأ، حسب المثال المذكور.

وهذا الماكرو لمن أراد:

 

Sub خطأترقيم()
'
' خطأترقيم Macro
'ماكرو يقوم بتتبع كل رقمين متتاليين، فإذا كان هناك رقمان تاليهما أكبر من السابق أو يساويه ظلله بالأصفر
'
    Selection.WholeStory
    Selection.Font.Color = wdColorAutomatic
    Selection.HomeKey Unit:=wdStory
    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
  
  
  For i = 1 To 100000
   Dim aa, b, c As Integer
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = wdColorAutomatic
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "[0???-9]، [0???-9]"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .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

   If Selection.Find.Found = False Then
   End
Else


    Selection.MoveLeft Unit:=wdWord, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    aa = Val(Selection.Text)

    Selection.MoveRight Unit:=wdWord, Count:=2
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    b = Val(Selection.Text) - 1
    Selection.MoveLeft Unit:=wdWord, Count:=1

If aa > b Then
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Options.DefaultHighlightColorIndex = wdYellow
    Selection.Range.HighlightColorIndex = wdYellow
    Selection.MoveRight Unit:=wdWord, Count:=1
    End If
End If
Next i


If Selection.Find.Found = False Then
    MsgBox ("تم تحديد الأرقام المتتالية بالخطأ")
    End If
Selection.HomeKey Unit:=wdStory
MsgBox ("تم تحديد الأرقام المتتالية بالخطأ")
End Sub

 

[أ / محمد صالح]

بارك الله لك

[Ali Mohamed Ali]

شكراً جزيلاً لهذا المجهود وجزاك الله خير الثواب

[أبو عاصم المصري]

بارك الله فيكم، نحن نتعلم منكم.