ماكرو لتحديد أرقام المجلدات التي بعدها سلاش (/) في فقرة إذا كان المسلسل خطأ

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

هذا ماكرو بسيط يقوم بتحديد أرقام المجلدات أو الأجزاء التي بعدها سلاش (/) ضمن فقرة معينة، بحيث يرصد كل رقمين للتأكد من أن التالي ليس اصغر من سابقه أو مساويه.

وهذا اختبار يحتاجه الباحث، حيث نجد أن أرقام المجلدات كثيرا ما تأتي غير مرتبة، فتجد مثلا: المجلد (5)، بعده (4)، أو (3) ونحو هذا، وهذا خطأ، ومن المعلوم أن تتبع أخطاء الأرقام من الصعوبة بمكان، لذا كان من الضروري معرفة هذه المواضع بطريقة آلية، لتكون أسرع وأضبط.

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

 

Sub مسلسلمجلداتخطأ()
'
' مسلسلمجلداتخطأ Macro
'ماكرو يقوم بتحديد أرقام الأجزاء التي بعدها سلاش مثل (3/5)لمعرفة الأرقام المترتبة خطأ، بحيث يكون الرقم التالي أقل من السابق أو مساويه، ويكون ذلك من خلال الفقرات
'والطريقة: أن تقف في أي موضع من الملف ثم تشغل الماكرو ليقوم بتمييز الأرقام الخطأ باللون الأصفر
    
    Dim aa, b, c As Integer
   
    Selection.HomeKey Unit:=wdStory
    Selection.TypeParagraph
    For i = 1 To ActiveDocument.Paragraphs.Count
    
    Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Font.Color = 10498160
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 10498160
    Selection.Find.Replacement.ClearFormatting
    
    For ii = 1 To 100
    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
    
   If Selection.Find.Found = False Then
   Exit For
   End
   End If
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Selection.Find.Execute
    Selection.Font.Color = wdColorRed
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Font.Color = wdColorRed
    aa = Val(Selection.Text)
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 10498160
    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
    
   If Selection.Find.Found = False Then
   Exit For
   End
   End If
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Selection.Find.Execute
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft 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

    Next ii
    
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 10498160
    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
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    Selection.MoveDown Unit:=wdParagraph, Count:=1
   Next i
   Selection.HomeKey Unit:=wdStory
   Selection.Delete Unit:=wdCharacter, Count:=1
 
End Sub

 

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

بارك الله لك

ونفع بك

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

أكرمكم الله أخانا الحبيب