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

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

03 عضو مميز
  • Posts

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

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

  • Days Won

    2

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

  1. فعلا، بارك الله في أخينا شحادة ابن بشير، بشَّره الله بما يسرُّه.
  2. هذا ماكرو لمن يحتاج استبدال مجموعة كلمات متباعدة في الورد، لأن هذه الخاصية يحتاجها الإخوة المصححون، وهي غير موجودة ضمن طرق البحث في الورد. وقد وقفت على هذا الماكرو في أحد المواقع الأجنبية، وأضفت عليه بعض اللمسات البسيطة ليسهل استعماله مع لغتنا العربية. والطريقة: 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
  3. عرفانا للجميل، وردا لبعض ما استفدته من هذا المنتدى المبارك، أقدم لإخواني (ماكرو تشكيل آلي) أستفيد منه كثيرا في مجال التشكيل، وهو عبارة عن ماكرو يقوم بالتالي: 1- ينسخ الكلمة أو الكلمتين، أو أكثر حسب تحديد الباحث، ثم يبحث بها في ملف آخر مشكول. 2- إذا وجد النص الذي يبحث عنه، فإنه ينسخه ويرجع إلى الملف غير المشكول، ليقوم باستبدال كل الكلمات غير المشكولة، فيضع مكانها المشكولة. 3- إذا لم يجد ما يبحث عنه، رجع إلى الملف ونسخ النص التالي ليبحث عنه، وهكذا. 4- يقوم بتلوين الكلمات المشكولة باللون الأحمر. 5- وفي نهاية العمليات يحفظ الملف بشكل آلي. 6- والمطلوب: أن تفتح ملف آخر مشكول ليبحث فيه الماكرو، فمثلا إذا كنت تشكل كتابا في الفقه فعليك أن تفتح ملفا آخر لكتاب فقه مشكول لينقل منه. 7- يجب أن تسمي الملف الذي تنقل منه التشكيل برمز معين، وليكن مثلا (----). 8- عند تشغيل الماكرو تخرج رسالة بعدد الكلمات المطلوب تشكيلها + 1 ، يعني لو أردت تشكيل كلمتين، فاكتب (3)، وإذا أردت تشكيل (4) اكتب (5)، وهكذا 9- والرسالة الثانية عدد مرات التكرار، يعني تكرر الأمر 100 مرة، أو 200، أو 1000، وهكذا. 10- والرسالة الثالثة فيها تحديد المدة، فيمكن أن تحدد المدة بالدقيقة، فلو كتبت (1) فهذا يعني أن الماكرو يعمل لدقيقة ثم يقف، ولو كتبت (2) فسيقف بعد دقيقتين، وهكذا. وهذا هو الماكرو لمن أراد: Sub تشكيلآلي() ' ' تشكيلآلي Macro 'ماكرو يشكل كلمات ملف من ملف آخر مشكول، بشرط فتح الملفين في آن واحد، وعند تشغيل الماكرو تختار عدد الكلمات المراد تشكيلها، كما تختار عدد مرات تكرار ذلك في الملف 'تمت إضافة تحديد الوقت في هذا الماكرو، فإذا كتبت (1) في مربع الوقت فهذا يعني دقيقةواحدة، وإذا كتبت(2)فهذايعني دقيقتين، وهكذا Dim X, a, b, c, y As Integer Dim t As Date t = Now Dim startTime As Date startTime = Now Do k = (InputBox("اكتب عدد الكلمات + 1")) X = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقيقة")) For i = 1 To X Selection.MoveRight unit:=wdWord, count:=1, Extend:=wdExtend 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 If (Len(Selection.Text) - 2 > 0) Then If Selection.Find.Found = False Then Windows(2).Activate Selection.MoveRight unit:=wdCharacter, count:=1 End If Selection.MoveLeft unit:=wdCharacter, count:=1 Selection.MoveLeft unit:=wdWord, count:=1 Selection.MoveLeft unit:=wdCharacter, count:=1 Selection.MoveRight unit:=wdWord, count:=k, Extend:=wdExtend a = Selection.Text 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 = False .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:=wdCharacter, count:=1 Else b = Selection.Text Windows(2).Activate Selection.MoveRight unit:=wdCharacter, count:=1 Selection.Find.ClearFormatting Selection.Find.Replacement.Font.Color = wdColorRed With Selection.Find .Text = a .Replacement.Text = b .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.MoveRight unit:=wdWord, count:=1 End If End If Next i Beep MsgBox "تم تشكيل الكلمات وتلوينها باللون الأحمر" & Format(Now - t, " والوقت المستغرق = h:n:s ") Exit Do Exit Sub Loop ActiveDocument.Save End Sub
  4. لقد وقعت في مثل هذه المشكلة، وعلى حد علمي لا يوجد لها حل جذري، لكني أجريت عدة عمليات ساعدتني بشكل كبير من حل هذه المشكلة، وهي: - استبدل كل تاء مربوطة (ة) بـ تاء مربوطة مسافة (ة ) - (ا) بـ (ا ) مع مطابقة شكل مع مطابقة همزة الألف. - (ى) بـ (ى ) - تبحث في الملف عن الكلمات الطويلة عن طريق البحث بأي حرف، مثل: (^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$^$) - تلونها باللون الأحمر مثلا، ثم تبحث في الملف عن الكلمات ذات اللون الأحمر، فإذا كان هناك التصاق فصلته . - وتكرر هذه العملية مع إنقاص حرف حتى تصل إلى حرفين، وبهذا يعود الملف إلى الوضع السليم. * هي عملية مرهقة، لكنها أفضل من إعادة كتابة الملف مرة أخرى.
  5. إلى الإخوة الأفاضل خبراء عمل الماكرو: هل هناك طريقة لتجاهل التشكيل مع حروف البدل، فإني أقوم بعمل ماكرو، أستخدم فيه حروف البدل بصورة غالبة، لكن واجهتني مشكلة، وهي أن الماكرو مع حروف البدل لا يتجاهل التشكيل، مما يضطني إلى تكرار الأمر بأكثر من صورة. في حين أنه لو تجاهل التشكيل، لاكتفيت بصورة واحدة.
  6. شكرا أخي محمد، توصلت لحل المشكلة، والأمر هو: If (Len(Selection.Text) - 2 > 0) Then والماكرو في صورته النهائية: Sub تشكيلآلي() ' تشكيلآلي Macro 'ماكرو يشكل كلمات ملف من ملف آخر مشكول، بشرط فتح الملفين في آن واحد، وعند تشغيل الماكرو تختار عدد الكلمات المراد تشكيلها، كما تختار عدد مرات تكرار ذلك في الملف' Dim x, a, b, c As Integer k = InputBox("اكتب عدد الكلمات + 1") x = InputBox("اكتب عدد مرات التنفيذ") For i = 1 To x Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend If (Len(Selection.Text) - 2 > 0) Then If Selection.Find.Found = False Then Windows(2).Activate Selection.MoveRight Unit:=wdCharacter, Count:=1 End If Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=1 Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.MoveRight Unit:=wdWord, Count:=k, Extend:=wdExtend a = Selection.Text 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 = False .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:=wdCharacter, Count:=1 Else b = Selection.Text Windows(2).Activate Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Find.ClearFormatting Selection.Find.Replacement.Font.Color = wdColorRed 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 Selection.MoveRight Unit:=wdWord, Count:=1 End If End If Next i Beep MsgBox "تم تشكيل الكلمات وتمييزها باللون الأحمر" End Sub
  7. هناك خيار في الماكرو يحدد عدد الكلمات المراد تشكيلها، وخيار آخر لعدد مرات التنفيذ. بمعنى أن تختار أن يقوم الماكرو بتشكيل (5) كلمات أو (4)، أو (3) مثلا متتالية. والخيار الثاني: أن يكرر هذه العملية في الملف مثلا (100) مرة، أو (200) مرة، وهكذا. والمطلوب هو: أمر: إذا وصلت العمليات إلى آخر كلمة في الملف يجب التوقف. فكرة الماكرو كالتالي: 1- فتح ملف كبير مشكول بالكامل. 2- فتح الملف المراد تشكيله. 3- نقوم بتشغيل الماكرو. 4- نختار عدد الكلمات المراد تشكيلها (5)، أو (4)، أو (3)، أو (2). 5- نختار عدد مرات التنفيذ (100)، أو (200) مثلا. 6- يقوم الماكرو بنسخ كلمتين أو ثلاثة مثلا حسب الاختيار. 7- يذهب إلى الملف المشكول ويبحث فيه عن هذه الكلمات مجتمعة. 8- إذا وجدها نسخها، ثم رجع إلى الملف المراد تشكيله وقام بعملية استبدال الكل، بحيث يستبدل كل الكلمات غير المشكولة بالمشكولة. 9- ثم يرجع خطوة، ثم يتحرك إلى الكلمة أو الكلمات التالية وتظليلها ونسخها. 10- الانتقال إلى الملف المشكول، وإجراء العملية السابقة. 11- هناك شرط: إذا لم يجد الكلمات التي يبحث عنها رجع إلى الملف الأول وتحرك مسافة كلمة. 12- كل هذا مع تلوين الكلمات المستبدلة باللون الأحمر لتمييزها. * الإشكال أنني عندما أصل إلى آخر صفحات في الملف، لا أعرف عدد مرات التكرار، فقد يكون عدد الكلمات مثلا (100)، وأنا طلبت منه أن ينفذ العملية (200) مرة، فيستمر في إعادة العمليات على الكلمات نفسها.لذا طلبت منك أخانا الحبيب أمرا ليوقف الماكرو إذا وصل إلى آخر الملف.ولك مني أطيب التحيات * ملحوظة: وضعت هذا السطر : If Len(Selection.Text) < 2 Then End بعد سطر تحديد الكلمات المراد تشكيلها، ليقف الماكرو إذا وجد المظلل أقل من حرفين، لكنه للأسف يوقف الماكرو عن علامات التنصيص «، »، [،]، (،)
  8. عفوا أستاذ محمد، ومعذرة لإثقالي عليك... أريد أيضا: أمر: إذا وصلت إلى آخر الملف توقَّف على غرار: if ..........then end
  9. تمام، بارك الله فيك أستاذ محمد، أنا عامل ماكرو تشكيل آلي، إن شاء الله عندما ينتهي أضعه هنا لمن أراد من الإخوة.
  10. الإخوة الأفاضل خبراء عمل ماكرو في الورد، هل هناك أمر معين معناه: نفّذ العملية من هنا إلى آخر كلمة في الملف؟ أو: إذا وصلت إلى آخر كلمة في الملف فتوقف، وذلك على غرار: ..............For i = 1 To أو If Selection....... = False Then end
  11. هذه مجموعة أكواد من حروف البدل أستخدمها كثيرا أثناء إجراء بعض العمليات في الورد، وقد أفادتني كثيرا، وللعلم: كثير من هذه الأكواد استفدتها من إخواننا الأفاضل في هذا المنتدى المبارك، ورأيت نشرها هنا لتعم الفائدة، والله من وراء القصد، وهذه هي الأوامر: - البحث عن كلمة أولها (ال) وآخرها (تنوين) <ال[! ]@[ًٌٍ]> - كلمة أولها (ال) وآخرها (ون) ليس بعدها (فتحة) ال[! ]@(ون)[!َ]> - البحث عن أي كلمة أو رمز، أو رقم: <[! ]*> - البحث عن أي كلمة: <[! ]@> - البحث عن أي كلمتين: <[! ]@> <[! ]@> - البحث عن أي كلمتين الأولى تبدأ بهمزة، والثانية تنتهي بتاء مربوطة: <أ[! ]@> <[! ]@ة> - البحث عن أي كلمتين الأولى آخرها ألف، والثانية تنتهي بالألف: <[! ]@ا> <[! ]@ا> - البحث عن أي فقرة إلى كلمة (في) مثلا للتظليل: <[! ]*في> - تحديد ما بين الفاصلتين: ، <[! ]*>، - تحديد ما بين كلمتين مثل: عن <[! ]*> عن - البحث عن أي كلمة مكونة من حرفين: <[! ]@{2}> - البحث عن أي كلمة مكونة من حرفين آخرها تنوين: <[! ]@{2}[!ًٌٍ]> - البحث عن كلمة خمس حروف ليس منها علامات الضبط: <[! ]@{5}[ًٌٍَُِّْ]> - للبحث عما بين قوسين هلاليين: (\(*)\) - للبحث عن أي رقم دون الحروف: [0???-9] - للبحث عن أي كلمة دون الأرقام: <[أ-ى][! ]@> - للبحث عن أي رقمين بينهما فاصلة: [0???-9]، [0???-9] - لتحديد ما بين شرطتين مائلتين: / [???0-9]*/ - لجعل علامة الحاشية بين قوسين: في مربع بحث اكتب الآتي ^f وفي مربع استبدال اكتب (^&) وهذا الكود يعني أن المكتوب في خانة البحث يساوي المكتوب في خانة الاستبدال، فيمكن استخدامه مع أي حرف وأي رقم، حيث الاستبدال لا ينفع مع أي حرف وأي رقم، لكن بإضافة هذا الكود يصبح الاستبدال متاحا. للبحث عن أي رقم بعده صفر (0) بعده سلاش (/) على صورة (08/):0^#/
  12. هذا ماكرو بسيط يقوم بتحديد أرقام المجلدات أو الأجزاء التي بعدها سلاش (/) ضمن فقرة معينة، بحيث يرصد كل رقمين للتأكد من أن التالي ليس اصغر من سابقه أو مساويه. وهذا اختبار يحتاجه الباحث، حيث نجد أن أرقام المجلدات كثيرا ما تأتي غير مرتبة، فتجد مثلا: المجلد (5)، بعده (4)، أو (3) ونحو هذا، وهذا خطأ، ومن المعلوم أن تتبع أخطاء الأرقام من الصعوبة بمكان، لذا كان من الضروري معرفة هذه المواضع بطريقة آلية، لتكون أسرع وأضبط. وهذا هو الماكرو لمن أراد: Sub مسلسلمجلداتخطأ() ' ' مسلسلمجلداتخطأ Macro 'ماكرو يقوم بتحديد أرقام الأجزاء التي بعدها سلاش مثل (3/5)لمعرفة الأرقام المترتبة خطأ، بحيث يكون الرقم التالي أقل من السابق أو مساويه، ويكون ذلك من خلال الفقرات 'والطريقة: أن تقف في أي موضع من الملف ثم تشغل الماكرو ليقوم بتمييز الأرقام الخطأ باللون الأصفر Dim aa, b, c As Integer Selection.HomeKey Unit:=wdStory Selection.TypeParagraph For i = 1 To ActiveDocument.Paragraphs.Count Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend Selection.Font.Color = 10498160 Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.Find.ClearFormatting Selection.Find.Font.Color = 10498160 Selection.Find.Replacement.ClearFormatting For ii = 1 To 100 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 If Selection.Find.Found = False Then Exit For End End If Selection.MoveDown Unit:=wdParagraph, Count:=1 Selection.Find.Execute Selection.Font.Color = wdColorRed Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend Selection.Font.Color = wdColorRed aa = Val(Selection.Text) Selection.MoveRight Unit:=wdWord, Count:=1 Selection.Find.ClearFormatting Selection.Find.Font.Color = 10498160 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 If Selection.Find.Found = False Then Exit For End End If Selection.MoveDown Unit:=wdParagraph, Count:=1 Selection.Find.Execute Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend b = Val(Selection.Text) - 1 Selection.MoveLeft Unit:=wdWord, Count:=1 If aa > b Then Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend Options.DefaultHighlightColorIndex = wdYellow Selection.Range.HighlightColorIndex = wdYellow Selection.MoveRight Unit:=wdWord, Count:=1 End If Next ii Selection.Find.ClearFormatting Selection.Find.Font.Color = 10498160 Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Color = wdColorAutomatic 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.MoveDown Unit:=wdParagraph, Count:=1 Next i Selection.HomeKey Unit:=wdStory Selection.Delete Unit:=wdCharacter, Count:=1 End Sub
  13. احتجت إلى عمل ماكرو يحدد الأرقام المتوالية بشكل خاطئ، بحيث يأتي مثلا (151) بعد (150)، أو يتكرر رقم (151) لكن بشرط أن يكون بين الرقمين فاصلة (،) وهذا يحدث كثيرا في الفهارس، فعملت هذا الماكرو ليقوم بتظليل أي رقم وقع في موضع الخطأ، حسب المثال المذكور. وهذا الماكرو لمن أراد: Sub خطأترقيم() ' ' خطأترقيم Macro 'ماكرو يقوم بتتبع كل رقمين متتاليين، فإذا كان هناك رقمان تاليهما أكبر من السابق أو يساويه ظلله بالأصفر ' Selection.WholeStory Selection.Font.Color = wdColorAutomatic Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Color = wdColorRed 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 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 For i = 1 To 100000 Dim aa, b, c As Integer Selection.Find.ClearFormatting Selection.Find.Font.Color = wdColorAutomatic Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "[0???-9]، [0???-9]" .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 If Selection.Find.Found = False Then End Else Selection.MoveLeft Unit:=wdWord, Count:=1 Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend aa = Val(Selection.Text) Selection.MoveRight Unit:=wdWord, Count:=2 Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend b = Val(Selection.Text) - 1 Selection.MoveLeft Unit:=wdWord, Count:=1 If aa > b Then Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend Options.DefaultHighlightColorIndex = wdYellow Selection.Range.HighlightColorIndex = wdYellow Selection.MoveRight Unit:=wdWord, Count:=1 End If End If Next i If Selection.Find.Found = False Then MsgBox ("تم تحديد الأرقام المتتالية بالخطأ") End If Selection.HomeKey Unit:=wdStory MsgBox ("تم تحديد الأرقام المتتالية بالخطأ") End Sub
  14. هذا الماكرو بعد ضبطه تماما، فهو يقوم بتحديد كل أرقام الأجزاء (المجلدات) المكررة، وتلوينها باللون الأرجواني: Sub رقمجزءمكرر() ' ' رقمجزءمكرر Macro 'لا بد أن يكون الكلام في جدول 'ماكرو يقوم بتحديد أرقام الأجزاء (المجلدات) المكررة، ويقوم بتلوينها باللون الأرجواني لحذفها، أو إجراء ما يلزم Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "/" .Replacement.Text = "" .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 Selection.SelectColumn Selection.Font.Color = wdColorAutomatic Selection.MoveUp Unit:=wdLine, Count:=1 Selection.HomeKey Unit:=wdLine For i = 1 To 1000 Selection.Find.ClearFormatting Selection.Find.Font.Color = wdColorAutomatic With Selection.Find .Text = "/" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchPrefix = True .MatchSuffix = True .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With If Selection.Find.Execute = False Then MsgBox "تم تغيير رقم الجزء المكرر إلى اللون الأرجواني": End Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend Selection.Font.Color = wdColorRed mm = Selection.Text Selection.HomeKey Unit:=wdLine Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend Selection.Find.ClearFormatting Selection.Find.Font.Color = wdColorAutomatic Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Color = 10498160 With Selection.Find .Text = mm .Replacement.Text = "^&" .Forward = False .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute replace:=wdReplaceAll 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.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend Selection.HomeKey Unit:=wdStory Selection.MoveRight Unit:=wdCell Selection.HomeKey Unit:=wdLine Next i End Sub
  15. بارك الله فيك أستاذ تومي، لكن أنا عملت ماكرو يقوم بتمييز أرقام الأجزاء المكررة باللون الأرجواني، فيجدد الماكرو كل أرقام الأجزاء المكررة، ليقوم الباحث بالنظر إلى ما يحتاج حذفا فيجذفه، لكنة ليس دقيقا مائة في المائة، وهذا هو الماكرو لمن أراد: Sub رقمجزءمكرر() ' ' رقمجزءمكرر Macro ' ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "/" .Replacement.Text = "" .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 Selection.SelectColumn Selection.Font.Color = wdColorAutomatic Selection.MoveUp Unit:=wdLine, Count:=1 Selection.HomeKey Unit:=wdLine For i = 1 To 1000 Selection.Find.ClearFormatting Selection.Find.Font.Color = wdColorAutomatic 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 If Selection.Find.Execute = False Then MsgBox "تم تغيير رقم الجزء المكرر إلى اللون الأرجواني": End Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend Selection.Font.Color = wdColorRed mm = Selection.Text Selection.HomeKey Unit:=wdLine Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend Selection.Find.ClearFormatting Selection.Find.Font.Color = wdColorAutomatic Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Color = 10498160 With Selection.Find .Text = mm .Replacement.Text = "^&" .Forward = False .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute replace:=wdReplaceAll 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.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend Selection.HomeKey Unit:=wdStory Selection.MoveRight Unit:=wdCell Selection.HomeKey Unit:=wdLine Next i End Sub
  16. أخانا الحبيب الأستاذ شحادة.. من خلال عملي في برنامج الورد، واستفادتي من إضافتكم الرائعة، وجدت اقتراحا ليتك تضعه موضع التنفيذ، لأنه سيكون إثراء للإضافة، وهو (الأرقام)، والاقتراح هو: 1- ترتيب الأرقام الموجودة على سطر، أو أكثر، لأن هذه ميزة ليست موجودة في الورد. 2- ترتيب أرقام الأجزاء، يعني مثلا لو جاء (5/20) بعد (6/20) يكون هناك خطأ في ترتيب الأجزاء. 3- إمكانية الترقيم على علامات معينة مثل (= ، * ، @) أو غيرها. 4- إمكانية وضع الأرقام بين []، أو ()، أو {}، أو غيرها، مع إمكانية إضافة رمز [أ] أو [ب] أوغيرهما، فيكون الترقيم [5أ]، [5ب] ونحو هذا، كما هو الحال في ترقيم المخطوطات. 5- إمكانية الترقيم عن طريق الجزء والصفحة، مثل [1/5]، [1/6]، [1/7]، [2/5].... وهكذا. 6- إمكانية عمل اختبار على الترقيم، بمعنى اكتشاف السقط أو الزيادة، كأن يأتي رقم (1501) بعد (1499)، وهذا يعني سقوط رقم (1500)، أو أن يأتي رقم مكرر، مثل (1500) بعد (1500). كل هذه أمور يحتاجها الباحث أثناء عمله من خلال برنامج الورد، ولا يخفى عليكم صعوبة تنفيذها. فإذا ما أضيفت هذه الخواص، أرى أنها ستكون في غاية الأهمية لكثير من الباحثين. سددكم الله وثبتكم. محبكم: أبو عاصم
  17. الإخوة الكرام.. هل هناك طريقة لترتيب أرقام الأجزاء والصفحات المتتالية بشكل مباشر إذا لم يكن بينها فقرات؟ يعني الأرقام بينها مسافات، وذلك مثل: 2/ 115، 114، 3/ 200، 150، 100، 4/ 30، 10، 20، 5/ 300 الرقم الأول هو رقم الجزء، والثاني: رقم الصفحة، وكما تلاحظون ليس هناك ترتيب لأرقام الصفحات، فصفحة (115) جاءت قبل (114)، وهكذا في بقية الأجزاء. ومعلوم أن الفرز في الورد لا يمكن إلا إذا كان هناك فقرة قبل الرقم. فاضطررت إلى أخذ نسخة من كل مجموعة (115، 114) وأضعها في ملف آخر مع وضع كل رقم في فقرة، ثم أرتب، ثم أنسخ المرتب مكان غير المرتب. فهل هناك طريقة أسهل من هذه؟
  18. الإخوة الكرام.. بعد تحيتي لكم جميعا، وتقديري للسادة القائمين على هذا المنتدى المبارك.. صادفتني مشكلة أثناء عملي في جدول في إحدى خلاياه أرقام أجزاء مع رقم الصفحة، على صورة 2/120، والمطلوب أن تكون الصورة كالتالي: 2/ 120، 130، 150، 3/ 170، 180، وهكذا، بحيث لا يتكرر رقم الجزء، فلا يكون: 2/ 120، 2/130، 2/150، 3/ 170، 3/180. لكن الملف عندي فيه تكرار رقم الجزء (2، 3)، وهذا غير مطلوب. والسؤال: هل هناك طريقة غير يدوية يتم فيها تحديد هذه المواضع التي تكرر فيها رقم الجزء في خليه واحدة؟
  19. بارك الله فيك أخانا الحبيب، وأنا -بفضل الله- في صدد تجميع قائمة بكل أعلام الكتب الستة وملحقاتها، عندما أنتهي منها إن شاء الله سأرسلها لك، بحيث يمكن إضافتها تحت مسمى قائمة أعلام الكتب الستة: الاسم، واللقب، والكنية، والنسبة. كل هذا بصورة واحدة للعلم، وهذه تخدم أي مفهرس يتعامل مع الأعلام، بحيث يأخذ العلم بصورة واحدة صحيحة. وهذه وظيفة يحتاجها كل من يتعامل مع كتب التراث.
×
×
  • اضف...

Important Information