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

بارك الله فيكم.

لعكس الترتيب كما في المثال اتبع الآتي: 1- احذف السلاش (/) عن طريق الاستبدال، وضع مكانها مسافة. 2- إجراء عملية الاستبدال مع حروف البدل: اكتب في مربع البحث: (<[0-9]@>) (<[0-9]@>) (<[0-9]@>) واكتب في مربع الاستبدال: \3 \2 \1 * لا بد أن تكون هذه الأرقام باللغة الإنجليزية واختر أن يكون مربع الاستبدال تحته خط (ctrl + u) 3- استبدال الكل، سيجعل الأرقام كما طلبت، ولكن دون السلاش (/). 4- افتح مربع الاستبدال، واختر في مربع البحث مسافة مع (ctrl + u) يعني استبدل مسافة تحتها خط. وفي خانة الاستبدال اكتب / وبهذا تكون كل الأرقام قد انعكست كما طلبت، ثم احذف الخط الذي تحت الأرقام والسلاش عن طريق البحث والاستبدال.

من الأمور التي نحتاجها أحيانا أن نرتب مجموعة أرقام على غرار (45، 30، 25، 15، 10، 5، 40، 20، 35، 50) والترتيب اليدوي يستغرق وقتا، كما أنه لم يسلم من الخطأ. وهذا الماكرو يقوم بعملية ترتيب أرقام محددة بمجرد تحديد هذه الأرقام وتشغيل الماكرو: ' ماكرو لترتيب أرقام محددة 'بحيث تظلل مجموعة أرقام بينها فاصلة (،) وتشغل الماكرو ليقوم بترتيب هذه الأرقام من الأصغر إلى الأكبر ' On Error Resume Next Dim objSelection As Range Dim strText As String Dim i As Long Dim arabicChars As String Dim StrData As String, j As Long, DataArray() Dim aa As String ''''''''''' Dim searchTerm1 As String Dim searchTerm2 As String Dim searchTerm3 As String Dim textToSearch As String Dim position1 As Integer Dim position2 As Integer If Len(Selection.Text) = 1 Then MsgBox "من فضلك ظلل الأرقام التي تريد ترتيبها" Beep Exit Sub Else End If '''''''''' إذا كان يوجد في النص المحدد هذه العلامات فأوقف الماكرو searchTerm1 = "-" searchTerm2 = "،" searchTerm3 = ":" textToSearch = Selection.Text position1 = InStr(1, textToSearch, searchTerm1) position2 = InStr(1, textToSearch, searchTerm2) position3 = InStr(1, textToSearch, searchTerm3) If position1 > 0 And position2 > 0 Then Beep MsgBox "يوجد أكثر من فاصل بين الأرقام المحددة" Exit Sub Else End If '''''''''' ''''''''''''''''''''''' لقفل الماكرو عند الضغط على زر escape aa = InputBox(Prompt:="حدد الفاصل بين الأرقام (، أو -) أو غيرهما", _ title:="ترتيب أرقـــــام", Default:="، ") If aa = "" Or _ aa = vbNullString Then Beep Exit Sub End If '''''''''''' ss = Selection.Text StrData = ss If InStr(Selection, aa) <> 0 Then '''''''''''' Beep Else: MsgBox "لا يوجد الفاصل الذي حددته بين الأرقام" '''' إذا لم يوجد فاصلة ضمن النص المحدد Exit Sub End If arabicChars = "أبتثجحخدذرزسشصضطظعغفقكلمنهويةئؤإآ" Set objSelection = Selection.Range strText = objSelection.Text For i = 1 To Len(arabicChars) If InStr(1, strText, Mid$(arabicChars, i, 1), vbBinaryCompare) > 0 Then MsgBox "الجملة المحددة تحتوي على حروف هجائية" Exit Sub End If Next i j = UBound(Split(StrData, aa)): ReDim DataArray(j) For i = 0 To j DataArray(i) = Split(StrData, aa)(i) Next WordBasic.sortArray DataArray() MsgBox Join(DataArray(), aa) Selection.TypeText Text:=Join(DataArray(), aa) Beep End Sub

عفوا

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

هذا الماكرو يستبدل مجموعة كلمات، ويضع مكانها كلمة واحدة. يعني يمكن أن تضع في خانة البحث: محمد ، أحمد ، إبراهيم وفي خانة الاستبدال: عمر وستحول كل المواضع التي فيها (محمد ، عمر ، إبراهيم) إلى (عمر) ' ' استبدال مجموعة كلمة متفرقة بكلمة واحد ' ' Dim xFind As String Dim xReplace As String Dim xFindArr, xReplaceArr Dim i As Long 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

أرسلت لك رقم تليفوني للتواصل

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

أحيانا تأتي الملفات بها أرقام تبدأ بصفر (0) أو أكثر، مثل (05)، (006)، (00010)، ونحو ذلك. ويحتاج الباحث إلى حذف هذه الأصفار، فيصبح الرقم: (5)، (6)، (10) والطريقة سهلة للغاية، وهي كتابة: <0 في خانة البحث، مع ترك خانة الاستبدال فارغة، واختيار حروف البدل. سيقوم هذا الأمر بحذف هذه الأصفار التي على يسار الرقم.

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

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

نحتاج كثيرا إلى اختبار أوائل صفوف الجداول أو أوائل الفقرات للبحث عن التكرار، سواء أكان تكرار كلمتين أو ثلاثة أو أكثر، وهذا ماكرو يفيدك في ذلك: ' ' سطران أو صفان أولهما متشابه ' ' 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