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

تفضل أخي الحبيب

نحتاج كثيرا إلى اختبار أوائل صفوف الجداول أو أوائل الفقرات للبحث عن التكرار، سواء أكان تكرار كلمتين أو ثلاثة أو أكثر، وهذا ماكرو يفيدك في ذلك:

'
' سطران أو صفان أولهما متشابه
'
'
   On Error Resume Next
    Dim sPrompt As String
    Dim sUserResp As String
    Dim iUR As Integer
    sPrompt = "1. بداية صفين متشابهة [جدول]" & vbCrLf
    sPrompt = sPrompt & "2. بداية فقرتين متشابهة [فقرات]" & vbCrLf
    
    iUR = 0 '''''''''''''''''
    While iUR < 1 Or iUR > 3
        sUserResp = InputBox(sPrompt, "اختر واحدًا مما يلي")
        iUR = Val(sUserResp)
        ''''''''''''''''' لإمكانية إلغاء جميع الاختيارات وقفل الكود
        If iUR = False Then
Exit Sub
End If
''''''''''''''''''''''
    Wend
    Select Case iUR
        
  Case 1
  If Selection.Information(wdWithInTable) = False Then
    MsgBox ("ضع المؤشر داخل الجدول")
    Exit Sub
  Else
 End If
   ss = InputBox("أدخل عدد الكلمات التي تريد مقارنتها في أول الصف")
   Do
       
    Selection.MoveRight Unit:=wdWord, Count:=ss, Extend:=wdExtend
    a = Selection.Text
    Selection.HomeKey Unit:=wdLine
    Selection.GoTo what:=wdGoToLine, Which:=wdGoToNext, Count:=1, name:=""

    Selection.MoveRight Unit:=wdWord, Count:=ss, Extend:=wdExtend
 b = Selection.Text
If a = b Then
Beep
If MsgBox("سجلان أولهما مكرر، هل ترغب في المتابعة؟", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Selection.HomeKey Unit:=wdLine
Loop Until (Selection.End = ActiveDocument.Content.End - 1)
Beep

  Case 2
  If Selection.Information(wdWithInTable) = True Then  ''' إذا كان المؤشر داخل جدول فتوقف عن العمل
    MsgBox (" لا يصلح هذا الاختيار داخل الجدول، اختر رقم 2 ")
    Exit Sub
  Else
 End If
    ss = InputBox("أدخل عدد الكلمات التي تريد مقارنتها في أول الفقرة")
    Do
    Selection.MoveRight Unit:=wdWord, Count:=ss, Extend:=wdExtend
    a = Selection.Text
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=ss, Extend:=wdExtend
     b = Selection.Text
If a = b Then
Beep
If MsgBox("فقرتان أولهما مكرر، هل ترغب في المتابعة؟", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Selection.HomeKey Unit:=wdLine
Loop Until (Selection.End = ActiveDocument.Content.End - 1)
End Select
Beep
End Sub

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

وهذا الماكرو يتيح لك ذلك:

'
' إضافة رمز معين، أو نص معين للخلايا الفارغة
'
'
    Dim tTable As Table
    Dim cCell As Cell
    Dim sTemp As String
    ss = InputBox("أدخل الرمز أو النص الذي تريد أن تجعله في الخلايا الفارغة")
    sTemp = ss
    For Each tTable In ActiveDocument.Range.Tables
        For Each cCell In tTable.Range.Cells
                If Len(cCell.Range.Text) < 3 Then
                cCell.Range = sTemp
            End If
        Next
    Next
    Set oCell = Nothing
    Set tTable = Nothing
End Sub

الأمر بسيط، فلو أنك فتحت أي ملف فيه كلمات مميزة بأي لون، وشغلت الماكرو سيقوم الماكرو باستخراج كل الكلمات أو الجمل المميزة مع أرقام صفحاتها إلى ملف آخر.

نعم، تفضل:

'
'ماكرو لإضافة مجموعة كلمات، أو جمل لاستخراجها آخر الملف مع أرقام الصفحات الموجودة فيها
'

Dim strList  As String
Dim Coll As Collection
Dim oRng As Range
Dim vName As Variant
Dim i As Integer, j As Integer

ss = InputBox("أدخل الكلمات التي تريد فهرستها آخر الملف مفصولة بفاصلة ")

strList = ss

vName = Split(strList, "،")
For i = 0 To UBound(vName)
Set Coll = New Collection
Set oRng = ActiveDocument.Range
oRng.End = ActiveDocument.Range.Paragraphs(ActiveDocument.Range.Paragraphs.Count - i).Range.START
With oRng.Find
Do While .Execute(vName(i))
Coll.Add oRng.Information(wdActiveEndPageNumber)
Loop
End With
ActiveDocument.Range.InsertAfter vbCr & vName(i) & ": "
For j = 1 To Coll.Count
ActiveDocument.Range.InsertAfter Coll(j)
If j < Coll.Count Then ActiveDocument.Range.InsertAfter ", "
Next j
Next i
lbl_Exit:
Set oRng = Nothing
Set Coll = Nothing
Selection.EndKey Unit:=wdStory
Beep
Exit Sub
End Sub

نعم، تفضل:

'
'ماكرو لإضافة مجموعة كلمات، أو جمل لاستخراجها آخر الملف مع أرقام الصفحات الموجودة فيها
'

Dim strList  As String
Dim Coll As Collection
Dim oRng As Range
Dim vName As Variant
Dim i As Integer, j As Integer

ss = InputBox("أدخل الكلمات التي تريد فهرستها آخر الملف مفصولة بفاصلة ")

strList = ss

vName = Split(strList, "،")
For i = 0 To UBound(vName)
Set Coll = New Collection
Set oRng = ActiveDocument.Range
oRng.End = ActiveDocument.Range.Paragraphs(ActiveDocument.Range.Paragraphs.Count - i).Range.START
With oRng.Find
Do While .Execute(vName(i))
Coll.Add oRng.Information(wdActiveEndPageNumber)
Loop
End With
ActiveDocument.Range.InsertAfter vbCr & vName(i) & ": "
For j = 1 To Coll.Count
ActiveDocument.Range.InsertAfter Coll(j)
If j < Coll.Count Then ActiveDocument.Range.InsertAfter ", "
Next j
Next i
lbl_Exit:
Set oRng = Nothing
Set Coll = Nothing
Selection.EndKey Unit:=wdStory
Beep
Exit Sub
End Sub

تحتاج أحيانا أن تكتب رقم الجزء مع الصفحة في مواضع مختلفة بصورة متكررة، وهذه المواضع ليس لها علامة محددة بحيث يمكن كتابة الترقيم بصورة آلية.

ومعلوم أن كتابة الأرقام بشكل متكرر لا يخلو من خطأ.

فهذا الماكرو يقوم بكتابة رقم الجزء والصفحة في الموضع الذي تحدده بين معقوفين على صورة [1/5]، [1/6]، وهكذا، ويمكن أن تغير رقم الجزء فيصبح [2/5]، [2/6] وهكذا.

وهذا الماكرو:

' إدراج رقم جزء وصفحة بين معقوفين في الموضع الحالي
'
'
    Dim ss, a As Integer
    Selection.TypeText Text:="^"
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "/<[0-9]@>\]"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindStop
        .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
  
       If Selection.Find.Found = False Then
       ss = InputBox("أدخل رقم الجزء", , "1")
 
If ss = False Then
Exit Sub
Else
End If
    Selection.TypeBackspace
    Selection.TypeText Text:="[" & ss & "/]"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1

 Else
 
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
  
    a = Val(Selection.Text)
   
    Selection.MoveLeft Unit:=wdWord, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=3, Extend:=wdExtend
    b = Selection.Text
    Selection.MoveRight Unit:=wdWord, Count:=3

    
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .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
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:=b
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="]"
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindStop
        .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
    Selection.TypeText Text:=Val(a) + 1
    Selection.MoveRight Unit:=wdCharacter, Count:=2
 
End If
Beep
End Sub

 

نحتاج كثيرا إلى ترتيب مجموعة أرقام في فقرة محددة كُتبت بينها فاصلة، لكنها لم يُراع فيها الترتيب، والورد لا يمكن أن يرتب هذه الأرقام إلا إذا كان كل رقم في فقرة.

مثال: ( 52، 25، 526، 528، 29، 530، 631، 532، 33) وهذه الأرقام مرتبة بشكل غير صحيح، ونحن نحتاج إلى ترتيبها لتصبح (  25، 29، 33 ،52، 526، 528، 530، 532)

وإذا أردت ذلك فعليك أولا أن تحدد هذه الأرقام المطلوب ترتيبها، ثم تشغل الماكرو ليقوم بترتيبها.

وهذا الماكرو:

' ماكرو لترتيب أرقام محددة
'بحيث تظلل مجموعة أرقام بينها فاصلة (،) وتشغل الماكرو ليقوم بترتيب هذه الأرقام من الأصغر إلى الأكبر
'
    
   On Error Resume Next
   If Len(Selection.Text) = 1 Then
   MsgBox "من فضلك ظلل الأرقام التي تريد ترتيبها"
   Exit Sub
   Else
   End If
   
   If MsgBox("تنبيه: عند تحديد الأرقام يجب ألا يكون بعد الرقم الأخير مسافة أو فاصلة، أو أي علامة ترقيم، فهل ترغب في المتابعة؟", vbQuestion + vbYesNo) <> vbYes Then
   Exit Sub
   End If
  
    Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Copy
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    
   If Selection.Text = Chr(161) Then    ' إذا كان آخر التظليل فاصلة
   ActiveWindow.Close (False)
   MsgBox ")،( لا يصح أن يكون آخر التظليل فاصلة "
   Exit Sub
   Else
   End If
    
  If Selection.Text = Chr(32) Then     ' إذا كان آخر التظليل مسافة
  ActiveWindow.Close (False)
  MsgBox "لا يصح أن يكون آخر التظليل مسافة"
  Exit Sub
   Else
   End If
    
    If Selection.Text = Chr(13) Then   ' إذا كان آخر التظليل مسافة كبيرة
    ActiveWindow.Close (False)
    MsgBox "لا يصح أن يكون آخر التظليل مسافة"
    Exit Sub
    Else
    End If
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "،"
        .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
    Selection.Sort ExcludeHeader:=False, FieldNumber:="فقرات", SortFieldType:= _
        wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, FieldNumber2:="", _
        SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:=wdSortOrderAscending _
        , FieldNumber3:="", SortFieldType3:=wdSortFieldAlphanumeric, SortOrder3:= _
        wdSortOrderAscending, Separator:=wdSortSeparateByTabs, SortColumn:=False, _
         CaseSensitive:=False, LanguageID:=wdArabic, SubFieldNumber:="فقرات", _
        SubFieldNumber2:="فقرات", SubFieldNumber3:="فقرات"
    Selection.Sort BidiSort:=False, IgnoreThe:=True, IgnoreKashida:=False, _
        IgnoreDiacritics:=False, IgnoreHe:=False
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "،"
        .Forward = True
        .Wrap = wdFindStop
        .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.EndKey Unit:=wdLine, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Copy
    Selection.PasteAndFormat (wdPasteDefault)
    ActiveWindow.Close (False)
    Selection.PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
Beep
End Sub

أكرمكم الله

لو عندك أي ملف مشكول فيه مثل هذه الكلمات، افعل الآتي:

1- ابحث عن أي كلمة آخرها ألف منوَّن: <[! ]@(ًا)> وفي خانة الاستبدال اختر (تمييز).

2- ابحث عن أي كلمة آخرها ألف قبله شدة وتنوين: <[! ]@(ًّا)> وفي خانة الاستبدال اختر (تمييز).

3- انسخ كل الكلمات المميزة (المنونة) إلى ملف آخر عن طريق البحث عن التمييز – مستند رئيسي.

4- افتح مستندا جديدا، وألصق فيه كل هذه الكلمات المميزة، واحفظ الملف بأي اسم، وليكن مثلا (كلمات منونة)

5- بهذا أصبح لديك قائمة بالكلمات التي آخرها ألف منوَّن.

6- افتح الملف المراد تشكيله، ثم شغِّل ماكرو التشكيل الآلي (أرسلته لك من قبل)

7- افتح من خلال ماكرو التشكيل ملف الكلمات المنونة، وسيقوم ماكرو التشكيل بتشكيل كل هذه الكلمات المنونة في الملف.

* وبهذا يصبح عندك قاعدة بيانات من الكلمات المنونة قابلة للزيادة.

 

استخدم هذا الماكرو، لاستبدال مجموعة كلمات متفرقة متباعدة بكلمة واحدة، مع مراعاة التشكيل:

بعد تشغيل الماكرو:

- ضع في خانة البحث :  أَيْضا ، أيْضا ، أيضًا ، أيضا

وفي خانة الاستبدال : أيضًا

أو : أَيْضًا 

أو حسب ما تريد من ضبط، مع مراعاة المسافات

ويمكن أيضا أن تضع كلمات مختلفة متباعدة في خانة البحث، لتستبدلها بكلمة واحدة.

 

' استبدال مجموعة كلمة متفرقة بكلمة واحدة
'
'
    Dim xFind As String
    Dim xReplace As String
    Dim xFindArr, xReplaceArr
    Dim i As Long
    Application.ScreenUpdating = False
    xFind = InputBox("أدخل هنا مجموعةالكلمات التي تريد استبدالها، مفصولة بفاصلة: ", "الكلمات المطلوب استبدالها")
    xReplace = InputBox(":أدخل الكلمة التي تريد استبدالها مكان الكلمات السابقة ", "الكلمة الجديدة")
    xFindArr = Split(xFind, "،")

    For i = 0 To UBound(xFindArr)
        
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = xFindArr(i)
            .Replacement.Text = xReplace
            .Format = False
            .MatchWholeWord = False
        End With
     Selection.Find.ClearFormatting       ' لو أردت حذف التمييز، فاحذف هذا السطر، والثلاثة التالية له
     Selection.Find.Replacement.ClearFormatting
     Selection.Find.Replacement.Highlight = True
     Options.DefaultHighlightColorIndex = wdBrightGreen
       Selection.Find.Execute Replace:=wdReplaceAll
    
    Next
    Application.ScreenUpdating = True
    Beep
    
End Sub

إذا أردت أن تبحث عن كلمة أو جملة لونها غير أسود، أو غير تلقائي، فهذا الماكرو سيفيدك إن شاء الله:

'
' البحث عن نص غير تلقائي (أسود)
'
'
 Dim OutPut As Integer
 With Selection.Find
          .Text = InputBox(prompt:=" : أدخل كلمة (جملة) البحث ", _
          Title:="البحث عن الكلمات أو الجمل غير السوداء")
            Do While .Execute
            With Selection.Font
                If (.Color <> wdColorAutomatic) And _
                  (.Color <> wdColorBlack) Then
               
   If MsgBox("البحث عن التالي", vbQuestion + vbYesNo) <> vbYes Then
   Exit Sub
   End If
   End If
   End With
   Loop
   End With
End Sub
 

نحتاج أحيانا إلى حصر كل الجداول الموجودة ضمن ملفات متعددة للنظر فيها على حدة.

وهذا ماكرو يبحث داخل الملفات التي تحددها داخل مجلد معين، فينسخ الجداول فقط، ثم يضعها في ملف مستقل لتنظر فيها.

وهذا الماكرو:

' نسخ الجداول من مجلد معين ووضعها في ملف واحد
Dim strFileName As String
Dim strPath As String
Dim oDoc As Document, oNewdoc As Document
Dim oTable As Range, oRng As Range
Dim oLog As Document
Dim bFound As Boolean
Dim fDialog As FileDialog
Dim oColl As New Collection
Dim i As Long, j As Long, k As Long
On Error Resume Next
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "حدد المجلد وانقر فوق موافق "
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "أُلغي الأمر", , _
                   "محتويات المجلد"
            GoTo lbl_Exit
        End If
        strPath = fDialog.SelectedItems.Item(1) & Chr(92)
    End With
    Set oNewdoc = Documents.Add

    strFileName = Dir$(strPath & "*.doc")

    While Len(strFileName) <> 0
        Set oDoc = Documents.Open(filename:=strPath & strFileName, AddToRecentFiles:=False)
        bFound = False
        If oDoc.ProtectionType = wdNoProtection Then
            If oDoc.Tables.Count > 0 Then
                k = 0
                bFound = True
                For i = 1 To oDoc.Tables.Count
                    Set oTable = oDoc.Tables(i).Range
                    oTable.Copy
                    Set oRng = oNewdoc.Range
                    oRng.Collapse 0
                    oRng.InsertParagraphAfter
                    Set oRng = oNewdoc.Range
                    oRng.Collapse 0
                    oRng.Paste
                    k = k + 1
                    DoEvents
                Next i
                If bFound = True Then
                    oColl.Add strFileName & vbTab & k & " tables copied"
                End If
            End If
            DoEvents
        End If
        oDoc.Close SaveChanges:=wdDoNotSaveChanges
        strFileName = Dir$()
    Wend
    Set oLog = Documents.Add
    For j = 1 To oColl.Count
        oLog.Range.InsertAfter oColl(j) & vbCr
    Next j
lbl_Exit:
    Exit Sub
Beep
End Sub
 

كثيرا ما ينسى مدخل البيانات وضع نقطة في آخر الفقرات للدلالة على نهايتها وبداية فقرة جديدة، وهذا غير صحيح.

وهذا ماكرو لوضع نقطة في آخر الفقرات التي ليس في آخرها نقطة، أما التي وُضعت نقطة في آخرها فتبقى نهاية الفقرة كما هي.

وهذا الماكرو:

'إضافة نقطة في آخر الفقرات التي ليس في آخرها نقطة
'

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Highlight = True
    Selection.Find.Replacement.Font.Underline = wdUnderlineSingle
    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.Highlight = False
    Selection.Find.Font.Underline = wdUnderlineNone
    Selection.Find.Replacement.ClearFormatting
    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.Highlight = False
    Selection.Find.Font.Underline = wdUnderlineNone
    Selection.Find.Replacement.ClearFormatting
    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
    Selection.Find.Replacement.Highlight = False
    Selection.Find.Replacement.Font.Underline = wdUnderlineNone
    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
Beep

   MsgBox "تم بحمد الله وضع نقطة في آخر الفقرات التي لا تنتهي بنقطة"

End Sub

• البحث عن كلمة أولها (ال) وآخرها (تنوين): <ال[! ]@[ًٌٍ]>

• كلمة أولها (ال) وآخرها (ون) ليس بعدها (فتحة): ال[! ]@(ون)[!َ]>

• البحث عن أي كلمة أو رمز، أو رقم: <[! ]*>

• البحث عن أي كلمة، وهي تصلح في عمل الماكرو: <[أ-ىيئءؤآءاإًٌٍَُِّْ]@>

• أو: <[أ-يَّآًٌٍُِْ]@>

• البحث عن أي كلمة: <[أ-ي]@> أو: <?@?>

• البحث عن أي كلمة: <[! ]@> يكتب قبلها كلمة عند البحث والاستبدال لأنها تبطئ الماكرو، وربما تهنج الورد.

• البحث عن أي كلمتين: <[! ]@> <[! ]@>

• البحث عن أي كلمتين الأولى تبدأ بهمزة، والثانية تنتهي بتاء مربوطة: <أ[! ]@> <[! ]@ة>

• البحث عن أي كلمتين الأولى آخرها ألف، والثانية تنتهي بالألف: <[! ]@ا> <[! ]@ا>

• البحث عن كلمتين متتاليتين مكررتين: (<* ){2} ، ويمكن البحث بـ{3، 4} أو <([أؤئإءيا-ى]@)> \1> أو: (<[ء-يا-ى]@)[ ,.;:]@\1>

• البحث عن كلمتين، أو عددين، أو جملتين متتاليتين مكررتين: (<*>) \1

• البحث عن كلمتين، أو عددين، أو جملتين متتاليتين مكررتين بينهما فاصلة: (<*>)، \1

• ولحذف الكلمة أو الجملة المكررة نضع في مربع الاستبدال: \1

• البحث عن حرفين أو رقمين متتاليين متطابقين: (?){2}

• البحث عن أي كلمتين أو حرفين أو رقمين متتاليين متطابقين: (<*){2}

• البحث عن أي كلمتين متطابقتين بينهما أي كلمة: (<[! ]@>) [! ]@ \1

• البحث عن آخر كلمة في الخلية (تنفع للشعر): <[أ-ىيئءؤءاإًٌٍَُِّْ]@>[! ء-ى]

• البحث عن آخر كلمة مشكولة في الخلية (تنفع للشعر): <[ء-ي]@[! ء-ي]>

• البحث عن آخر كلمة مشكولة في الخلية آخرها (ا-و-ى-ي) (للشِّعر): <[ء-ي]@[! ء-ي][اوىي]>

• البحث عن آخر كلمة مشكولة في الخلية بعدها مسافة (للشِّعر): <[ء-ي]@[! ء-ي]>

• البحث عن آخر كلمة ليس بها أي تشكيل في الخلية (للشِّعر): <[ء-ي]@[!  ًٌٍَُِّْ]>[! ء-يٰ]

                       • أو: <[ء-ي]@>[!? ٰ]

• البحث عن أي كلمة في الخلية عدا الكلمة الأخيرة: <[أ-ىيئءؤآءاإًٌٍَُِّْ]@>[!^13]

• البحث عن أي كلمة في الخلية عدا الكلمة الأولى: [!^13]<[أ-ىيئءؤآءاإًٌٍَُِّْ]@>

• البحث عن كلمة في الخلية عدا الأولى والأخيرة: [!^13]<[أ-ىيئءؤآءاإًٌٍَُِّْ]@>[!^13]

• البحث عن أي رقمين متتاليين بينهما فاصلة مثل 22، 22، ويمكن بـ{3، 4}: (<*){2}، (<*){2}

• البحث عن أي رقمين متتاليين بينهما فاصلة، وليس قبلهما سلاش: [!\/]<[0-9]@>، <[0-9]@>[!\/]

• البحث عن أي رقمين متتاليين بينهما فاصلة، الثاني ليس قبله سلاش: <[0-9]@>، <[0-9]@>[!\/]

• البحث عن فقرة وتظليلها: (*^13)

• البحث عن فقرتين متتاليتين متطابقتين: (*^13)\1

• البحث عن ثلاث فقرات متتالية متطابقة: (*^13)\1\1

• البحث عن فقرة قبلها فقرة فارغة وبعدها فقرة فارغة: ^13{2}([!^13]@^13)^13

• البحث عن فقرة قبلها فقرة فارغة: ^13{2}([!^13]@^13)

• البحث عن فقرة قبلها أو بعدها فقرة فارغة: ^13{2}([!^13]@)

• ولحذف هاتين الفقرتين الفارغتين ضع في خانة الاستبدال: ^p<H1>\1

• البحث عن الفقرات المكررة بشكل متتالي: (*^13)(\1)@

• البحث عن فقرة عن طريق حروف البدل: ^13

• البحث عن فقرة قبلها أي حرف عن طريق حروف البدل: >^13 ، وبعدم اعتبار المسافة آخر الفقرة: >^13*

• البحث عن أي فقرة إلى كلمة (في) مثلا للتظليل: <[! ]*في>

• البحث عن فقرة ليس في نهايتها (.) أو (:) أو (؟) أو (!): ([!^13.:\؟\!\-\!]^13)

• تحديد ما بين الفاصلتين: ، <[! ]*>،

• تحديد ما بين أي كلمتين متطابقتين: (<[! ]@>) [! ]* \1

• تحديد أي كلمتين متطابقتين بعد كل منهما أي كلمة: (<[! ]@>) [! ]@ \1 (<[! ]@>)

• تحديد ما بين كلمتين مثل: عن <[! ]*> عن

• البحث عن أي كلمة مكونة من حرفين: <[! ]@{2}>

• البحث عن أي كلمة مكونة من حرفين آخرها تنوين: <[! ]@{2}[!ًٌٍ]> 

• البحث عن كلمة خمس حروف ليس منها علامات الضبط: <[! ]@{5}[ًٌٍَُِّْ]>

• للبحث عما بين قوسين هلاليين: (\(*)\) أو \(?@\)

• للبحث عما بين قوسين هلاليين باستثناء علامة الحاشية: \(<[أ-ىيئءؤءاإًٌٍَُِّْ]*>\)

• للبحث عما بين معقوفين: \[?@\]

• للبحث عن أي رقم دون الحروف: [0???-9]

• للبحث عن أي رقم فردي أو زوجي أو أكثر: <[0-9]@>

• لتظليل رقم بعده سلاش (شرطة مائلة/) حتى آخر الفقرة: <[0-9]@>/*^13

• لوضع كل رقم بعده سلاش في فقرة: في خانة البحث: <[0-9]@>/ وفي الاستبدال: ^13^&

• للبحث عن رقم واحد: <[0-9]{1}> أو رقمين: <[0-9]{2}> وهكذا بزيادة رقم بين {}

• للبحث عن أي كلمة دون الأرقام: <[أ-ى][! ]@>

• للبحث عن أي رقمين بينهما فاصلة: [0???-9]، [0???-9]

• للبحث عن الأرقام بين سلاشين شرطتين مائلتين //: /[???0-9]*/

• للبحث عن أي رقم حتى نهاية الفقرة: [0-9]*^13

• للبحث عن الحروف والأرقام دون المسافات وعلامات الترقيم: [أ-ي0-9]

• البحث عن الحاشية السفلية مع حروف البدل: ^2

• البحث عن الحاشية الفارغة التي بعد رقمها قوس هلالي:  ^2\) [!ء-ي]

• البحث عن الحاشية الفارغة التي ليست بين قوسين:  ^2[!\)][!ء-ي]

• البحث عن حاشية قبل علامة الترقيم: ([.:،؛\?\!])\(^2\)

• البحث عن قوس مربع [ ليس له قوس غلق ] : \[[!\]]@^13

• البحث عن قوس هلالي ( ليس له قوس غلق ) : \([!\)]@^13

• البحث عن قوس مدبب ( ليس له قوس غلق ) : \«[!\»]@^13

• البحث عن قوس مرعوش ( ليس له قوس غلق ) : \{[!\}]@^13

• لعكس ترتيب كلمات متتالية مثل: عماد محمد أحمد، نضع في خانة البحث: (عماد) (محمد) (أحمد)

                                      : وفي خانة الاستبدال:  \3 \2 \1

مع مراعاة أن تكون الأرقام باللغة الإنجليزية.

• لنقل كلمة مكان سابقتها والعكس، مثل: محمد عمر ، نضع في خانة البحث: (محمد) (عمر)

                                                                : وفي خانة الاستبدال:  \2 \1

• لنقل علامة الحاشية قبل علامة الترقيم: في خانة البحث: ([.،:;\?\!])(\(^2\))

                                                                       : وفي خانة الاستبدال: \2\1

• للبحث عن أكثر من مسافة متتالية: [  ]@([! ])

• ولجعلها مسافة واحدة نستبدلها بـ:  \1

• لجعل علامة الحاشية بين قوسين: في مربع بحث اكتب الآتي ^f وفي مربع استبدال اكتب  (^&) وهذا الكود يعني أن المكتوب في خانة البحث يساوي المكتوب في خانة الاستبدال، فيمكن استخدامه مع أي حرف وأي رقم، حيث الاستبدال لا ينفع مع أي حرف وأي رقم، لكن بإضافة هذا الكود يصبح الاستبدال متاحا.

• لإضافة صفر بعد رقمين مثل (015): نضع في خانة البحث: <[0-9]{2}> وفي الاستبدال: 0^&

• لإضافة صفر بعد رقم واحد، مثل (05): في خانة البحث: <[0-9]{1}> وفي الاستبدال: 0^&

• للبحث عن أي رقم بعده صفر (0) بعده سلاش (/) على صورة (08/): 0^#/

دعوة صالحة...

الماكرو يطلب منك أولا فتح ملف مشكول، ويفضل أن تكون المادة العلمية مشابهة للملف المراد تشكيله، بمعنى أنك إذا أردت أن تشكل ملفا في الحديث، فينبغي أن يكون الملف المشكول في الحديث، وإن كان في الفقه فكذلك.

ويفضل أيضا أن تبدأ بعدد كلمات أكبر، فتبدأ بست كلمات، ثم خمسة، ثم أربعة،... وهكذا، ليكون التشكيل أدق.

ويستحسن في البداية أن تكون المدة قليلة، يعني ابدأ بخمس دقائق، ثم عشرة، وهكذا، لأن برنامج الورد يستهلك قدرا كبيرا من الذاكرة، ويمكن أن يهنج الجهاز.

وهذا الماكرو:

'
'تشكيل آلي لكلمة واحدة أو اثنتين حتى ست كلمات، بحيث يبحث الماكرو عن الكلمات غير المشكولة ويقوم بتشكيلها
'
'
Dim objDoc As Document    '''''' لإغلاق ملفات الورد عدا الذي فيه المؤشر
  Dim objDocumentsToBeClosed As New Collection
  Dim nCount As Integer
 
  nCount = Application.Documents.count
  For nIndex = 1 To nCount
    Set objDoc = Application.Documents.Item(nIndex)
    If objDoc.FullName <> ActiveDocument.FullName Then
      objDocumentsToBeClosed.Add objDoc
    Else
      Exit For
    End If
  Next nIndex
  For Each objDoc In objDocumentsToBeClosed
    objDoc.Close SaveChanges:=wdSaveChanges
  Next objDoc  '''''''
 Dim xFileDialog As FileDialog, GetStr(1 To 100) As String '  الحد الأقصى (100) ملف
Dim xFindStr As String
Dim xReplaceStr As String
Dim xDoc As Document
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
With xFileDialog
    .Filters.Clear
    .Filters.Add "All WORD File ", "*.docx", 1
    .AllowMultiSelect = True
    i = 1
    If .Show = -1 Then
        For Each stiSelectedItem In .SelectedItems
            GetStr(i) = stiSelectedItem
            i = i + 1
        Next
        i = i - 1
    End If
    Application.ScreenUpdating = False
    xFindStr = a
    xReplaceStr = b
    For j = 1 To i Step 1
        Set xDoc = Documents.Open(FileName:=GetStr(j), Visible:=False)
        Windows(GetStr(j)).Activate
    Dim sPrompt As String
    Dim sUserResp As String
    Dim iUR As Integer
    Dim t As Date
  
   
   t = Now
   Dim StartTime As Date
   StartTime = Now
   Do

    sPrompt = "1. تشكيل كلمة واحدة" & vbCrLf
    sPrompt = sPrompt & "2. تشكيل كلمتين" & vbCrLf
    sPrompt = sPrompt & "3. تشكيل ثلاث كلمات" & vbCrLf
    sPrompt = sPrompt & "4. تشكيل أربع كلمات" & vbCrLf
    sPrompt = sPrompt & "5. تشكيل خمس كلمات" & vbCrLf
    sPrompt = sPrompt & "6. تشكيل ثلاث كلمات" & vbCrLf
    
    iUR = 0   '''''''''''''''''
    While iUR < 1 Or iUR > 6
        sUserResp = InputBox(sPrompt, "اختر واحدًا مما يلي")
        iUR = Val(sUserResp)
        
        ''''''''''''''''' لإمكانية إلغاء جميع الاختيارات وقفل الكود
        If iUR = False Then
Exit Sub

End If
'''''''''''''''''''''' لعمل case لعدة خيارات في  InputBox
    Wend
    Select Case iUR
        Case 1

   aa = (" <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
    y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   Case 2
   
   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
    y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   
   Case 3

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))

   Case 4

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))

   Case 5

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   Case 6

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   End Select
   
   For i = 1 To x
  If DateDiff("n", StartTime, Now, endTime) = y Then
    
    ' s =عدد الثواني
    ' n =الدقائق
    ' h =ساعة
    
    MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s  ")
        
    Exit Do
         
    Exit Sub
    ActiveDocument.Save
    End If
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = aa
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .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
   If Selection.Find.Found = False Then
    Exit Sub
   Else
   End If
   a = Selection.Text
    Selection.MoveLeft Unit:=wdCharacter, count:=1
    Selection.MoveRight Unit:=wdCharacter, count:=1
    Selection.MoveLeft Unit:=wdCharacter, count:=1
    Windows(1).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = a
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
   If Selection.Find.Found = False Then
    Windows(2).Activate
  Selection.MoveRight Unit:=wdWord, count:=2

 
   Else
   
   b = Selection.Text
    Selection.MoveRight Unit:=wdCharacter, count:=1
    Windows(2).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = 49407     ' اللون البرتقالي
    With Selection.Find
        .Text = a
        .Replacement.Text = b
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = True
        .MatchAlefHamza = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    End If
Selection.MoveRight Unit:=wdWord, count:=2

Next i
 Beep

   MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s  ")
        
    Exit Do
    Exit Sub
    Loop
ActiveDocument.Save
Next
End With
Beep
Windows(1).Close (False)    '''''' لإغلاق الملف الذي كان يعمل في الخلفية
End Sub

نعم، لو كنت تريد ذلك من أجل التشكيل، أو ضبط الكلمات، فعندي ماكرو يفيد في ذلك، لو أردتَه أرسلتُه لك.

جرِّب  على هذا الوضع

 

مسودة.docx

أكرمكم الله أخي الفاضل

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

فتفضل:

'
' ترتيب شعر حسب الحركات : سكون- فتح - ضم - كسر، مع مراعاة ترتيب حروف الكلمة أيضا
'لا بد من تشكيل الحرف الأخير من من الكلمة الأخيرة في الشطر الثاني
'إذا كان الحرف الأخير ألفا أو واوا أو ياء فيشكل الحرف قبل الحروف الثلاثة
    If Len(Selection.Text) = 1 Then
   MsgBox "من فضلك ظلل عمود الشطر الثاني الذي فيه القافية"
   Exit Sub
   End If
 
  Do
   On Error Resume Next
    Selection.Font.Color = 10498160
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 10498160 ' البحث عن اللون الأرجواني باختيار الأسفل
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .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
    Selection.Font.Color = wdColorAutomatic
    Selection.EndKey Unit:=wdLine
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "<[أ-ىيئءؤآءاإًٌٍَُِّْ]@>"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindStop
        .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
    Selection.Copy
    Selection.SelectRow
    Selection.HomeKey Unit:=wdLine
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    If Selection.Font.Underline = wdUnderlineNone Then
        Selection.Font.Underline = wdUnderlineSingle
    Else
        Selection.Font.Underline = wdUnderlineNone
    End If
    Selection.Font.Color = 5287936
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 5287936
    End With
    Selection.Find.Replacement.ClearFormatting  ' البحث عن الشدة أو السكون أو الفتحة أو الضمة أو الكسرة باتجاه الأعلى ونسخها
    With Selection.Find
        .Text = "[َُِّْ]"
        .Replacement.Text = ""
        .Forward = False
        .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
   Selection.Copy
    
   If Selection.Find.Found = False Then ' إذا لم يكن هناك تشكيل على الكلمة الأخيرة فلون الكلمة باللون الأرجواني وانتقل إلى الصف التالي
   Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Color = 10498160
    Selection.SelectCell
    Selection.MoveDown Unit:=wdLine, Count:=1 '''''''''''''''''''''''''''''''''''''''
Else
  
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Color = 10498160
    Selection.HomeKey Unit:=wdLine
    Selection.TypeText Text:="["
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.TypeText Text:="]"
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Color = 192
    
    Selection.SelectCell
    Selection.MoveDown Unit:=wdLine, Count:=1
End If
Loop Until (Selection.End = ActiveDocument.Content.End - 1)
Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    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
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Do
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .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
   Selection = StrReverse(Selection) ' عكس ترتيب حروف الكلمة
    Selection.SelectCell
    Selection.MoveDown Unit:=wdLine, Count:=1
Loop Until (Selection.End = ActiveDocument.Content.End - 1)

Selection.Find.ClearFormatting
    Selection.Find.Font.Underline = wdUnderlineSingle
    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.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Font.Underline = wdUnderlineSingle
    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 = True
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Font.Underline = wdUnderlineSingle
    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 = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    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 = True
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Font.Underline = wdUnderlineSingle
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Underline = wdUnderlineSingle
    With Selection.Find   ' وضع التشكيل الذي بن معقوفين بعد الحرف الأول من الكلمة
        .Text = "(\[[-َُِّْ]\])(?)"
        .Replacement.Text = "\2\1"
        .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.HomeKey Unit:=wdLine
findArray = Array("[ْ]", "[ّ]", "[َ]", "[ُ]", "[ِ]")     ' تغيير التشكيل إلى أرقام، يعني: السكون= 1، والشدة = 2، والفتحة= 3، والضمة = 4، والكسرة = 5
    replArray = Array("1", "2", "3", "4", "5")
For i = 0 To UBound(findArray)   ' لتنفيذ الأمر حتى آخر الملف
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = findArray(i)
        .Replacement.Text = replArray(i)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next i ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' وذلك لمراعاة الترتيب بالحرف الأول ثم الرقم
 Selection.HomeKey Unit:=wdStory
    Selection.Sort ExcludeHeader:=False, FieldNumber:="عمود 1", SortFieldType _
        :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, FieldNumber2 _
        :="عمود 1", SortFieldType2:=wdSortFieldNumeric, SortOrder2:= _
        wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
        wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
        wdSortSeparateByCommas, SortColumn:=False, CaseSensitive:=False, _
        LanguageID:=wdArabicYemen, SubFieldNumber:="فقرات", SubFieldNumber2:= _
        "فقرات", SubFieldNumber3:="فقرات"
    Selection.Sort BidiSort:=False, IgnoreThe:=True, IgnoreKashida:=False, _
        IgnoreDiacritics:=False, IgnoreHe:=False
    Selection.Find.ClearFormatting
Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    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.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 192
    End With
    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.Execute Replace:=wdReplaceAll
    Selection.HomeKey Unit:=wdStory
Beep
End Sub

 

لو أحببت ماكرو آخر لترتيب الأبيات حسب الحركات (سكون - فتح - ضم - كسر) عندي أيضا

بارك الله في أخويَّ مصطفى وشحادة...

فكرة ماكرو ترتيب الشعر بسيطة، وهي كالتالي:

1- تحديد الشطر الذي فيه القافية.

2- اختيار الكلمة الأخيرة من هذا الشطر (القافية).

3- نسخها ووضعها في أول الشطر الأول مقلوبة الحروف بلون مخالف، يعني إذا كانت الكلمة (نقصان) ستصبح (ناصقن).

4- ثم نحذف الألف والواو والياء التي لا تصلح أن تكون قافية.

5- ثم نرتب الجدول حسب العمود الأول.

6- نحذف هذه الكلمات المقلوبة عن طريق لونها.

وبهذا يكون الشعر مرتبا حسب حروف الهجاء (همزة، باء، تاء،.....)

ويتبقى فقط مشكلة الهاء التي لا تصلح أن تكون قافية، وهذه لا بد فيها من التدخل اليدوي.

*ملحوظة: الطريقة نفسها تنفع مع ترتيب القوافي (يعني قائمة القوافي) مثل: (إنسان- نقصان- تميل- الأمل) وهكذا.

مع وافر تقديري واحترامي

الماكرو يعمل بصورة صحيحة، وقام بترتيب الملف

تخير يوما باللبل أتواصل مع حضرتك بصورة مباشرة حتى تتضح الصورة

احذف أي شيء في الملف إلا الجدول، ولا تترك مسافة قبل الجدول، وسيعمل بشكل سليم إن شاء الله.

ولو لم يتيسر لك، فأرسل لي الملف أو جزءا منه وسأجرب عليه الماكرو لمعرفة السبب.

ومعذرة على التأخير، فلم يتيسر لي النظر إلى الرسائل إلا الآن

تفضل أخي مصطفى، هذا ماكرو لترتيب أبيات شعرية في جدول من خلال الورد:

'
'
'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط
'
  On Error Resume Next
    
   If Len(Selection.Text) = 1 Then
   MsgBox "من فضلك ظلل عمود الشطر الثاني الذي فيه القافية"
   Exit Sub
   End If
    
    Selection.Font.Color = 10498160
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    
  For i = 1 To 100000
    Selection.EndKey Unit:=wdLine
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 10498160
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^$"
        .Replacement.Text = ""
        .Forward = False
        .Wrap = wdFindStop
        .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
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Copy
    Selection.SelectRow
    Selection.Font.Color = wdColorAutomatic
    Selection.HomeKey Unit:=wdLine
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    If Selection.Font.Underline = wdUnderlineNone Then
        Selection.Font.Underline = wdUnderlineSingle
    Else
        Selection.Font.Underline = wdUnderlineNone
    End If
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "[ًٌٍَُِّْ]"
        .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 Replace:=wdReplaceAll
    
   Selection = StrReverse(Selection)
    
    
    Selection.HomeKey Unit:=wdLine
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineNone
        .Color = 10498160
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^$"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .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
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
If Selection.Find.Found = False Then
   Exit For
End If
Next i

 Selection.HomeKey Unit:=wdStory
    
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    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 = True
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Sort ExcludeHeader:=False, FieldNumber:="عمود 1", SortFieldType _
        :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, FieldNumber2 _
        :="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
        wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
        wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
        wdSortSeparateByCommas, SortColumn:=False, CaseSensitive:=False, _
        LanguageID:=wdArabic, SubFieldNumber:="فقرات", SubFieldNumber2:="فقرات", _
        SubFieldNumber3:="فقرات"
    Selection.Sort BidiSort:=False, IgnoreThe:=True, IgnoreKashida:=False, _
        IgnoreDiacritics:=False, IgnoreHe:=False
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .Color = 10498160
    End With
    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.Execute Replace:=wdReplaceAll
    Selection.HomeKey Unit:=wdStory
     Beep
    MsgBox "تم ترتيب الشعر بنجاح"
End Sub