(وهذا أيضا مهم للفهرسة) استخراج كلمات أو جمل لها لون محدد مع رقم الصفحة:

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

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

On Error Resume Next
strFontColor = InputBox(" : اختر لون الخط - رقمه " & vbNewLine & _
      vbTab & "تلقائي" & vbTab & vbTab & "0" & vbNewLine & _
      vbTab & "أسود" & vbTab & vbTab & "1" & vbNewLine & _
      vbTab & "أزرق" & vbTab & vbTab & "2" & vbNewLine & _
      vbTab & "أخضر فاتح" & vbTab & "4" & vbNewLine & _
      vbTab & "أزرق غامق" & vbTab & vbTab & "9" & vbNewLine & _
      vbTab & "أحمر غامق" & vbTab & vbTab & "13" & vbNewLine & _
      vbTab & "أصفر غامق" & vbTab & "14" & vbNewLine & _
      vbTab & "رمادي 25" & vbTab & vbTab & "16" & vbNewLine & _
      vbTab & "رمادي 50" & vbTab & vbTab & "15" & vbNewLine & _
      vbTab & "أخضر" & vbTab & vbTab & "11" & vbNewLine & _
      vbTab & "قرنفلي" & vbTab & vbTab & "5" & vbNewLine & _
      vbTab & "أحمر" & vbTab & vbTab & "6" & vbNewLine & _
      vbTab & "نهري" & vbTab & vbTab & "10" & vbNewLine & _
      vbTab & "تركواز" & vbTab & "3" & vbNewLine & _
      vbTab & "بنفسجي" & vbTab & vbTab & "12" & vbNewLine & _
      vbTab & "أبيض" & vbTab & vbTab & "8" & vbNewLine & _
      vbTab & "أصفر" & vbTab & vbTab & "7", "قائــــــــــــــمة الألــــــوان")
  With Selection

Dim dic As Object
Dim r As Range, k
Dim s As String, p As Long
Dim Tbl As Table, n As Long

Set dic = CreateObject("scripting.dictionary")

Set r = ActiveDocument.Content
r.Collapse
With r.Find
.Font.ColorIndex = strFontColor
Do While .Execute
s = Trim(r.Text)
If Len(s) > 1 Then
If Not dic.Exists(s) Then
Set dic(s) = CreateObject("scripting.dictionary")
End If
p = r.Information(wdActiveEndPageNumber)
dic(s)(p) = Empty
End If
Loop
End With

If dic.Count = 0 Then Exit Sub

Set r = ActiveDocument.Bookmarks("\EndOfDoc").Range

Set Tbl = ActiveDocument.Tables.Add(r, dic.Count, 2)

For Each k In dic
n = n + 1
Tbl.Cell(n, 1).Range.Text = k
Tbl.Cell(n, 2).Range.Text = Join(dic(k).Keys, "، ")
Next
End With
Selection.EndKey Unit:=wdStory
Beep
End Sub

[حامل المسك]

مبدع،،، الله يوفقك،،

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

اللهم آمين، ولك مثل ذلك

[antoninomubarik]

مبدع،،، الله يوفقك،،

Showbox jiofi.local.html tplinklogin

تم تعديل مايو 12, 2023 بواسطه antoninomubarik

[تومي محمد]

شيء رائع

[محمد سيد٧٩]

شكرا جزيلا 

هل ممكن كود يحتوي على نسخ النص المحدد ونسخ رقم الصفحة معه ليتم اللصق في ملف جديد

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

نعم، تفضل:

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

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