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

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

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

بواسطه أبو عاصم المصري
في منتدي الوورد Word

 مشاركة

الردود الموصى بها

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

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

قام بنشر
قام بنشر

• البحث عن كلمة أولها (ال) وآخرها (تنوين): <ال[! ]@[ًٌٍ]>

• كلمة أولها (ال) وآخرها (ون) ليس بعدها (فتحة): ال[! ]@(ون)[!َ]>

• البحث عن أي كلمة أو رمز، أو رقم: <[! ]*>

• البحث عن أي كلمة، وهي تصلح في عمل الماكرو: <[أ-ىيئءؤءاإًٌٍَُِّْ]@>

• أو: <[أ-يًٌٍَُِّْ]@>

• البحث عن أي كلمة: <[أ-ي]@> أو: <?@?>

• البحث عن أي كلمة: <[! ]@> يكتب قبلها كلمة عند البحث والاستبدال لأنها تبطئ الماكرو، وربما تهنج الورد.

• البحث عن أي كلمتين: <[! ]@> <[! ]@>

• البحث عن أي كلمتين الأولى تبدأ بهمزة، والثانية تنتهي بتاء مربوطة: <أ[! ]@> <[! ]@ة>

• البحث عن أي كلمتين الأولى آخرها ألف، والثانية تنتهي بالألف: <[! ]@ا> <[! ]@ا>

• البحث عن كلمتين متتاليتين مكررتين: (<* ){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^#/

  • Like 1
  • 3 weeks later...
مصطفى شاهين

مصطفى شاهين

قام بنشر
قام بنشر (معدل)

حياكم الله أخي أبو عاصم

بارك الله في جهودك الطيبة، معلومات طيبة ومفيدة، بوركت

سؤالي: 

• البحث عن آخر كلمة في الخلية (تنفع للشعر): <[أ-ىيئءؤءاإًٌٍَُِّْ]@>[! ء-ى]

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

مع الشكر

تم تعديل بواسطه مصطفى شاهين
أبو عاصم المصري

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

قام بنشر
  • الكاتب
قام بنشر

تفضل أخي مصطفى، هذا ماكرو لترتيب أبيات شعرية في جدول من خلال الورد:

'
'
'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط
'
  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

  • Like 1
مصطفى شاهين

مصطفى شاهين

قام بنشر
قام بنشر
في 12‏/6‏/2023 at 08:47, أبو عاصم المصري said:

تفضل أخي مصطفى، هذا ماكرو لترتيب أبيات شعرية في جدول من خلال الورد:

 

بارك الله فيك أخي الفاضل أبو عاصم المصري، ما شاء الله، مُبدع

الله يعطيك العافية

شاكر لك جهودك الطيبة

  • Like 1
مصطفى شاهين

مصطفى شاهين

قام بنشر
قام بنشر

السلام عليكم ورحمة الله وبركاته،،،

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

لاطلاعكم لطفاً

image.png.a32888992703fbb3176c6300d3c3acf3.png

  • Like 1
أبو عاصم المصري

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

قام بنشر
  • الكاتب
قام بنشر

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

ولو لم يتيسر لك، فأرسل لي الملف أو جزءا منه وسأجرب عليه الماكرو لمعرفة السبب.

ومعذرة على التأخير، فلم يتيسر لي النظر إلى الرسائل إلا الآن

مصطفى شاهين

مصطفى شاهين

قام بنشر
قام بنشر (معدل)
في 25‏/6‏/2023 at 15:44, أبو عاصم المصري said:

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

بداية، كل عام وأنتم بخير

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

لاطلاعكم لطفاً

شعر - عينة.rar

تم تعديل بواسطه مصطفى شاهين
شحادة بشير

شحادة بشير

قام بنشر
قام بنشر

الأخ أبو عاصم المصري، جزاك الله خيراً على الكود.

الأخ مصطفى شاهين، فضلاً، انسخ الكود التالي كاملاً: 

Sub TrtebShar()
'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط
'
  On Error Resume Next
    
  If Selection.Information(wdWithInTable) = True Then
    'تحديد العمود الثالث
    Selection.Tables(1).Columns(3).Select
  End If

   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

 

  • Like 1
أبو عاصم المصري

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

قام بنشر
  • الكاتب
قام بنشر

بارك الله في أخويَّ مصطفى وشحادة...

فكرة ماكرو ترتيب الشعر بسيطة، وهي كالتالي:

1- تحديد الشطر الذي فيه القافية.

2- اختيار الكلمة الأخيرة من هذا الشطر (القافية).

3- نسخها ووضعها في أول الشطر الأول مقلوبة الحروف بلون مخالف، يعني إذا كانت الكلمة (نقصان) ستصبح (ناصقن).

4- ثم نحذف الألف والواو والياء التي لا تصلح أن تكون قافية.

5- ثم نرتب الجدول حسب العمود الأول.

6- نحذف هذه الكلمات المقلوبة عن طريق لونها.

وبهذا يكون الشعر مرتبا حسب حروف الهجاء (همزة، باء، تاء،.....)

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

*ملحوظة: الطريقة نفسها تنفع مع ترتيب القوافي (يعني قائمة القوافي) مثل: (إنسان- نقصان- تميل- الأمل) وهكذا.

مع وافر تقديري واحترامي

شحادة بشير

شحادة بشير

قام بنشر
قام بنشر
3 ساعات مضت, مصطفى شاهين said:

بارك الله فيك أخي شحادة

ظهرت رسالة خطأ

image.png.f1b1a08e5c0718e2ec38450fcf906b62.png

أخي العزيز مصطفى ما يظهر في صورتك ليس هو الماكرو الذي أرسلته في مشاركتي، فالماكرو الذي أرسلته في مشاركتي يبدأ بهذه الأكواد: 

Sub TrtebShar()
'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط
'
  On Error Resume Next
    
  If Selection.Information(wdWithInTable) = True Then
    'تحديد العمود الثالث
    Selection.Tables(1).Columns(3).Select
  End If

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

Sub TrtebShar()
'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط
'
  On Error Resume Next
    
  If Selection.Information(wdWithInTable) = True Then
    'تحديد العمود الثالث
    Selection.Tables(1).Columns(3).Select
  End If

   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

 

محمود ابوالخير

محمود ابوالخير

قام بنشر
قام بنشر (معدل)

السلام عليكم ورحمة الله وبركاته

كنت اريد كود vba لحفظ ملف ورد وأخذ اسم المستند من المستند النشط من السطر ١٦ وهي الارقام قبل وبعد كلمة لسنة ونفصل بين ارقام قبل (-) ارقام بعد

واجتهد وتم كتابة هذا الكود وبه خطأ لا اعرف تحديده

انتظر توجيهاتكم

 

 

03-07-2023.jpg

تم تعديل بواسطه محمود ابوالخير
مصطفى شاهين

مصطفى شاهين

قام بنشر
قام بنشر
في 6‏/7‏/2023 at 10:31, شحادة بشير said:

أخي العزيز مصطفى ما يظهر في صورتك ليس هو الماكرو الذي أرسلته في مشاركتي، فالماكرو الذي أرسلته في مشاركتي يبدأ بهذه الأكواد: 

 

بارك الله فيك أخي شحادة، وكذلك الشكر موصول لأخي أبو عاصم

تم تعديل الكود، وسارت الأمور على أفضل ما يكون

ما شاء الله تبارك الله، بوركت الجهود الطيبة؛ لخدمة الباحثين والمهتمين بهذا المجال

يعطيكم العافية

دمتم بخير

مصطفى شاهين

مصطفى شاهين

قام بنشر
قام بنشر
16 ساعات مضت, أبو عاصم المصري said:

لو أحببت ماكرو آخر لترتيب الأبيات حسب الحركات (سكون - فتح - ضم - كسر) عندي أيضا

بارك الله فيك أخي أبو عاصم

أنتظر الماكرو الخاص بترتيب الأبيات حسب الحركات.

أشكر لك جهودك الطيبة

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

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

قام بنشر
  • الكاتب
قام بنشر

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

فتفضل:

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

 

  • 1 year later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept