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

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

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

الطريقة: بعد إضافة الماكرو إلى الورد وتشغيل الماكرو:

1- سيظهر لك مربع حوار أول للكلمات التي تريد استبدالها، فتكتبها مفصولة بفاصلة (،) ثم تضغط على (ok)

2- سيظهر مربع الحوار الثاني للكلمات الجديدة، فتكتبها أيضا مفصولة بفاصلة (،) بشرط أن يكون عدد الكلمات في مربع الحوار الثاني مساويا لعدد الكلمات الموجودة في مربع الحوار الأول ثم تضغط على (ok)

* النتيجة: سيتم استبدال كل كلمة بما يقابلها مع أن هذه الكلمات متباعدة.

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

 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)
        
        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

 

 

[مدحت هنداوي]

جزاكم الله خيراً.

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

أحسن الله إليكم ونفع بكم.

 

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

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

[مدحت هنداوي]

في 25‏/7‏/2023 at 15:12, أبو عاصم المصري said:

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

جزاك الله خيراً أستاذنا على الاهتمام والرد .
هل توجد تكلفة مادية لهذا الماكرو ؟ وإن كانت فكم تبلغ ؟
وكيف يمكن التواصل مع حضرتك ؟
نفع الله بكم .

 

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

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

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

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

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

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

'
'تشكيل آلي لكلمة واحدة أو اثنتين حتى ست كلمات، بحيث يبحث الماكرو عن الكلمات غير المشكولة ويقوم بتشكيلها
'
'
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

تم تعديل يوليو 30, 2023 بواسطه أبو عاصم المصري

[مدحت هنداوي]

جزاك الله خيراً كثيراً . ودعوات بظهر الغيب بإذن الله .

[عبد الله العراقي]

اخي عاصم ممكن التواصل مع حضرتك لو سمحت

تم تعديل الإثنين at 07:57 بواسطه عبد الله العراقي

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

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