اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

03 عضو مميز
  • Posts

    154
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    2

كل منشورات العضو أبو عاصم المصري

  1. نحتاج كثيرا إلى اختبار أوائل صفوف الجداول أو أوائل الفقرات للبحث عن التكرار، سواء أكان تكرار كلمتين أو ثلاثة أو أكثر، وهذا ماكرو يفيدك في ذلك: ' ' سطران أو صفان أولهما متشابه ' ' 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
  2. تحتاج أحيانا للبحث عن الخلايا الفارغة في الجدول لكتابة رمز معين، أو نص معين للبحث عنه، أو استكمال شيء ناقص، أو غير ذلك. وهذا الماكرو يتيح لك ذلك: ' ' إضافة رمز معين، أو نص معين للخلايا الفارغة ' ' 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
  3. الأمر بسيط، فلو أنك فتحت أي ملف فيه كلمات مميزة بأي لون، وشغلت الماكرو سيقوم الماكرو باستخراج كل الكلمات أو الجمل المميزة مع أرقام صفحاتها إلى ملف آخر.
  4. نعم، تفضل: ' 'ماكرو لإضافة مجموعة كلمات، أو جمل لاستخراجها آخر الملف مع أرقام الصفحات الموجودة فيها ' 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
  5. نعم، تفضل: ' 'ماكرو لإضافة مجموعة كلمات، أو جمل لاستخراجها آخر الملف مع أرقام الصفحات الموجودة فيها ' 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
  6. تحتاج أحيانا أن تكتب رقم الجزء مع الصفحة في مواضع مختلفة بصورة متكررة، وهذه المواضع ليس لها علامة محددة بحيث يمكن كتابة الترقيم بصورة آلية. ومعلوم أن كتابة الأرقام بشكل متكرر لا يخلو من خطأ. فهذا الماكرو يقوم بكتابة رقم الجزء والصفحة في الموضع الذي تحدده بين معقوفين على صورة [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
  7. نحتاج كثيرا إلى ترتيب مجموعة أرقام في فقرة محددة كُتبت بينها فاصلة، لكنها لم يُراع فيها الترتيب، والورد لا يمكن أن يرتب هذه الأرقام إلا إذا كان كل رقم في فقرة. مثال: ( 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
  8. لو عندك أي ملف مشكول فيه مثل هذه الكلمات، افعل الآتي: 1- ابحث عن أي كلمة آخرها ألف منوَّن: <[! ]@(ًا)> وفي خانة الاستبدال اختر (تمييز). 2- ابحث عن أي كلمة آخرها ألف قبله شدة وتنوين: <[! ]@(ًّا)> وفي خانة الاستبدال اختر (تمييز). 3- انسخ كل الكلمات المميزة (المنونة) إلى ملف آخر عن طريق البحث عن التمييز – مستند رئيسي. 4- افتح مستندا جديدا، وألصق فيه كل هذه الكلمات المميزة، واحفظ الملف بأي اسم، وليكن مثلا (كلمات منونة) 5- بهذا أصبح لديك قائمة بالكلمات التي آخرها ألف منوَّن. 6- افتح الملف المراد تشكيله، ثم شغِّل ماكرو التشكيل الآلي (أرسلته لك من قبل) 7- افتح من خلال ماكرو التشكيل ملف الكلمات المنونة، وسيقوم ماكرو التشكيل بتشكيل كل هذه الكلمات المنونة في الملف. * وبهذا يصبح عندك قاعدة بيانات من الكلمات المنونة قابلة للزيادة.
  9. استخدم هذا الماكرو، لاستبدال مجموعة كلمات متفرقة متباعدة بكلمة واحدة، مع مراعاة التشكيل: بعد تشغيل الماكرو: - ضع في خانة البحث : أَيْضا ، أيْضا ، أيضًا ، أيضا وفي خانة الاستبدال : أيضًا أو : أَيْضًا أو حسب ما تريد من ضبط، مع مراعاة المسافات ويمكن أيضا أن تضع كلمات مختلفة متباعدة في خانة البحث، لتستبدلها بكلمة واحدة. ' استبدال مجموعة كلمة متفرقة بكلمة واحدة ' ' 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
  10. إذا أردت أن تبحث عن كلمة أو جملة لونها غير أسود، أو غير تلقائي، فهذا الماكرو سيفيدك إن شاء الله: ' ' البحث عن نص غير تلقائي (أسود) ' ' 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
  11. نحتاج أحيانا إلى حصر كل الجداول الموجودة ضمن ملفات متعددة للنظر فيها على حدة. وهذا ماكرو يبحث داخل الملفات التي تحددها داخل مجلد معين، فينسخ الجداول فقط، ثم يضعها في ملف مستقل لتنظر فيها. وهذا الماكرو: ' نسخ الجداول من مجلد معين ووضعها في ملف واحد 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
  12. كثيرا ما ينسى مدخل البيانات وضع نقطة في آخر الفقرات للدلالة على نهايتها وبداية فقرة جديدة، وهذا غير صحيح. وهذا ماكرو لوضع نقطة في آخر الفقرات التي ليس في آخرها نقطة، أما التي وُضعت نقطة في آخرها فتبقى نهاية الفقرة كما هي. وهذا الماكرو: 'إضافة نقطة في آخر الفقرات التي ليس في آخرها نقطة ' 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
  13. • البحث عن كلمة أولها (ال) وآخرها (تنوين): <ال[! ]@[ًٌٍ]> • كلمة أولها (ال) وآخرها (ون) ليس بعدها (فتحة): ال[! ]@(ون)[!َ]> • البحث عن أي كلمة أو رمز، أو رقم: <[! ]*> • البحث عن أي كلمة، وهي تصلح في عمل الماكرو: <[أ-ىيئءؤآءاإًٌٍَُِّْ]@> • أو: <[أ-يَّآًٌٍُِْ]@> • البحث عن أي كلمة: <[أ-ي]@> أو: <?@?> • البحث عن أي كلمة: <[! ]@> يكتب قبلها كلمة عند البحث والاستبدال لأنها تبطئ الماكرو، وربما تهنج الورد. • البحث عن أي كلمتين: <[! ]@> <[! ]@> • البحث عن أي كلمتين الأولى تبدأ بهمزة، والثانية تنتهي بتاء مربوطة: <أ[! ]@> <[! ]@ة> • البحث عن أي كلمتين الأولى آخرها ألف، والثانية تنتهي بالألف: <[! ]@ا> <[! ]@ا> • البحث عن كلمتين متتاليتين مكررتين: (<* ){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^#/
  14. دعوة صالحة... الماكرو يطلب منك أولا فتح ملف مشكول، ويفضل أن تكون المادة العلمية مشابهة للملف المراد تشكيله، بمعنى أنك إذا أردت أن تشكل ملفا في الحديث، فينبغي أن يكون الملف المشكول في الحديث، وإن كان في الفقه فكذلك. ويفضل أيضا أن تبدأ بعدد كلمات أكبر، فتبدأ بست كلمات، ثم خمسة، ثم أربعة،... وهكذا، ليكون التشكيل أدق. ويستحسن في البداية أن تكون المدة قليلة، يعني ابدأ بخمس دقائق، ثم عشرة، وهكذا، لأن برنامج الورد يستهلك قدرا كبيرا من الذاكرة، ويمكن أن يهنج الجهاز. وهذا الماكرو: ' 'تشكيل آلي لكلمة واحدة أو اثنتين حتى ست كلمات، بحيث يبحث الماكرو عن الكلمات غير المشكولة ويقوم بتشكيلها ' ' 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
  15. نعم، لو كنت تريد ذلك من أجل التشكيل، أو ضبط الكلمات، فعندي ماكرو يفيد في ذلك، لو أردتَه أرسلتُه لك.
  16. هذا ماكرو يقوم بترتيب الأبيات الشعرية الموجودة في الجدول، فيبدأ أولا بحرف الهمزة، وبداخلها يكون الترتيب حسب الحركات (سكون - فتح - ضم - كسر)، ثم الباء، والتاء.... وهكذا إلى آخر حروف الهجاء، لكنه يحتاج إلى مراجعة، خصوصا حرف الهاء، حيث يأتي أحيانا على أنه قافية، وأخرى يأتي زائدا لا يصلح أن يكون قافية، وهنا تضع البيت في موضعه، وهذا يحتاج متخصصا. فتفضل: ' ' ترتيب شعر حسب الحركات : سكون- فتح - ضم - كسر، مع مراعاة ترتيب حروف الكلمة أيضا 'لا بد من تشكيل الحرف الأخير من من الكلمة الأخيرة في الشطر الثاني 'إذا كان الحرف الأخير ألفا أو واوا أو ياء فيشكل الحرف قبل الحروف الثلاثة 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
  17. لو أحببت ماكرو آخر لترتيب الأبيات حسب الحركات (سكون - فتح - ضم - كسر) عندي أيضا
  18. بارك الله في أخويَّ مصطفى وشحادة... فكرة ماكرو ترتيب الشعر بسيطة، وهي كالتالي: 1- تحديد الشطر الذي فيه القافية. 2- اختيار الكلمة الأخيرة من هذا الشطر (القافية). 3- نسخها ووضعها في أول الشطر الأول مقلوبة الحروف بلون مخالف، يعني إذا كانت الكلمة (نقصان) ستصبح (ناصقن). 4- ثم نحذف الألف والواو والياء التي لا تصلح أن تكون قافية. 5- ثم نرتب الجدول حسب العمود الأول. 6- نحذف هذه الكلمات المقلوبة عن طريق لونها. وبهذا يكون الشعر مرتبا حسب حروف الهجاء (همزة، باء، تاء،.....) ويتبقى فقط مشكلة الهاء التي لا تصلح أن تكون قافية، وهذه لا بد فيها من التدخل اليدوي. *ملحوظة: الطريقة نفسها تنفع مع ترتيب القوافي (يعني قائمة القوافي) مثل: (إنسان- نقصان- تميل- الأمل) وهكذا. مع وافر تقديري واحترامي
  19. الماكرو يعمل بصورة صحيحة، وقام بترتيب الملف تخير يوما باللبل أتواصل مع حضرتك بصورة مباشرة حتى تتضح الصورة
  20. احذف أي شيء في الملف إلا الجدول، ولا تترك مسافة قبل الجدول، وسيعمل بشكل سليم إن شاء الله. ولو لم يتيسر لك، فأرسل لي الملف أو جزءا منه وسأجرب عليه الماكرو لمعرفة السبب. ومعذرة على التأخير، فلم يتيسر لي النظر إلى الرسائل إلا الآن
  21. تفضل أخي مصطفى، هذا ماكرو لترتيب أبيات شعرية في جدول من خلال الورد: ' ' 'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط ' 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
  22. • البحث عن كلمة أولها (ال) وآخرها (تنوين): <ال[! ]@[ًٌٍ]> • كلمة أولها (ال) وآخرها (ون) ليس بعدها (فتحة): ال[! ]@(ون)[!َ]> • البحث عن أي كلمة أو رمز، أو رقم: <[! ]*> • البحث عن أي كلمة، وهي تصلح في عمل الماكرو: <[أ-ىيئءؤءاإًٌٍَُِّْ]@> • أو: <[أ-يًٌٍَُِّْ]@> • البحث عن أي كلمة: <[أ-ي]@> أو: <?@?> • البحث عن أي كلمة: <[! ]@> يكتب قبلها كلمة عند البحث والاستبدال لأنها تبطئ الماكرو، وربما تهنج الورد. • البحث عن أي كلمتين: <[! ]@> <[! ]@> • البحث عن أي كلمتين الأولى تبدأ بهمزة، والثانية تنتهي بتاء مربوطة: <أ[! ]@> <[! ]@ة> • البحث عن أي كلمتين الأولى آخرها ألف، والثانية تنتهي بالألف: <[! ]@ا> <[! ]@ا> • البحث عن كلمتين متتاليتين مكررتين: (<* ){2} ، ويمكن البحث بـ{3، 4} أو <([أؤئإءيا-ى]@)> \1> أو: (<[ء-يا-ى]@)[ ,.;:]@\1> • البحث عن كلمتين، أو عددين، أو جملتين متتاليتين مكررتين: (<*>) \1 • البحث عن كلمتين، أو عددين، أو جملتين متتاليتين مكررتين بينهما فاصلة: (<*>)، \1 • ولحذف الكلمة أو الجملة المكررة نضع في مربع الاستبدال: \1 • البحث عن حرفين أو رقمين متتاليين متطابقين: (?){2} • البحث عن أي كلمتين أو حرفين أو رقمين متتاليين متطابقين: (<*){2} • البحث عن أي كلمتين متطابقتين بينهما أي كلمة: (<[! ]@>) [! ]@ \1 • البحث عن آخر كلمة في الخلية (تنفع للشعر): <[أ-ىيئءؤءاإًٌٍَُِّْ]@>[! ء-ى] • البحث عن أي رقمين متتاليين بينهما فاصلة مثل 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]{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^#/
×
×
  • اضف...

Important Information