ماكرو لاستبدال كلمات متعددة ومتباعدة في برنامج الورد

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

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

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

والطريقة:

1- بعد تشغيل الماكرو سيظهر لك حقل، تكتب فيه الكلمات التي تريدد استبدالها في الملف، وهي متباعدة، ولا بد أن يكون بعد كل كلمة فاصلة (،)، وإذا اخترت استبدال كلمتين تجعل الفاصلة بعد الكلمتين.

2- تضغط (ok).

3- ستظهر لك شاشة ثانية: تكتب فيها الكلمات السابقة مطابقة تماما، ثم تضبطها بالضبط الكامل، أو تضبط ما يحتاج ضبطا منها. (ولا تنس الفاصلة بين الكلمات)

4- تضغط (ok)، ليقوم الماكرو باستبدال الكلمات غير المشكولة ليضع مكانها الكلمات المشكولة.

* ملحوظة: يمكن أن تجمع مئات الكلمات في ملف (txt) مرة غير مشكولة، وأخرى مشكولة، فتنسخ غير المشكول، فتضعه في الحقل الأول، وتنسخ المشكولة في الحقل الثاني، ثم تنفذ الأمر.

* ملحوظة أخرى: يجب أن يكون عدد الكلمات متساويا في الحقلين، يعني إذا وضعت في الحقل الأول (3) كلمات، فيجب أن يكون الثاني (3) كلمات، وإذا اختلف العدد، فستخرج رسالة، تبين لك ذلك.

مع خالص تقديري للإخوة المشرفين والأعضاء جميعا، وتقبلوا تحياتي.

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

Sub استبدالمتعدد()

'
' استبدالمتعدد Macro
'ماكرو لاستبدال كلمات متعددة متباعدة
'
   
    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, "،")
    xReplaceArr = Split(xReplace, "،")
    If UBound(xFindArr) <> UBound(xReplaceArr) Then
        MsgBox "يجب التطابق في عدد الكلمات المطلوب استبدالها", vbInformation, "صل على المبعوث رحمة للعالمين"
        Exit Sub
    End If
    For I = 0 To UBound(xFindArr)
        Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = xFindArr(I)
            .Replacement.Text = xReplaceArr(I)
            .Format = False
            .MatchWholeWord = False
        End With
        Selection.Find.Execute replace:=wdReplaceAll
    Next
    Application.ScreenUpdating = True
    Beep
    
End Sub
 

[تومي محمد]

شكرا