Jump to content
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

ماكرو لترتيب أبيات شعرية ضمن جدول


Recommended Posts

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

* ويشترط أن تكون الأبيات ضمن جدول، وأن يوجد الشطران، وألا يكون في الصفحة إلا جدول الشعر فقط، بمعنى أنه لا يوجد عنوان مثلا قبل الفهرس، مثل: فهرس الشعر، ويمكن أن تضيفة بعد الترتيب الآلي واليدوي:

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


'
' شعرعماد Macro
'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط
'ويشترط وجود الشطرين
    Selection.Tables(1).Select
    Selection.Font.Color = wdColorAutomatic
    Selection.HomeKey Unit:=wdStory
    Selection.MoveRight Unit:=wdCell
    Selection.MoveRight Unit:=wdCell
    Selection.SelectColumn
    Selection.Font.Color = wdColorRed
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = wdColorRed
    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
    
  For i = 1 To 1000
      
    Selection.Find.Execute
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Copy
    
    If Selection.Find.Found = False Then
Selection.HomeKey Unit:=wdStory
Exit For
MsgBox "لا توجد كلمات حمراء"
End If
    
    Selection.Font.Color = wdColorAutomatic
    Selection.HomeKey Unit:=wdRow, Extend:=True
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Font.Color = 12611584
    Selection.HomeKey Unit:=wdLine
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, name:=""
    Selection.Find.ClearFormatting
    Selection.Find.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
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With

Next i


    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 12611584
    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
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 12611584
    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.ClearFormatting
    Selection.Find.Font.Color = 12611584
    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
    
  For i = 1 To 1000
    
    Selection.Find.Execute
    
   If Selection.Find.Found = False Then
Selection.HomeKey Unit:=wdStory
Exit For
MsgBox "لا توجد كلمات زرقاء"
End If
    
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=2
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Cut
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Font.Color = 5287936

Next i

    Selection.HomeKey Unit:=wdLine
    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.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = 5287936
    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
    Selection.Tables(1).Select
    Selection.Font.Color = wdColorAutomatic
    Selection.HomeKey Unit:=wdStory
End Sub
 

Link to post
Share on other sites

هذه صورة الجدول قبل الترتيب:

رُبَّ مَنْ أنضَجتُ غيظًا قلبَهُ
 

 

قد تمنَّى لي موتًا لم يُطَعْ
 

رُبَّما تَكْرَهُ النُّفُوسُ من الأمْر
 

 

ما لَهُ فَرْجةٌ كَحَلِّ العِقالِ
 

سَراةُ بَني أبي بَكْرٍ تَسامَوْا
 

 

عَلَى كانَ المُسَوَّمةِ العِرابِ
 

عُمَيرةَ ودِّعْ إنْ تَجَهَّزْتَ غادِيا
 

 

كَفَي الشّيْبُ والإسْلامُ لِلْمَرْءِ ناهِيا
 

قلّدوها تمائمًا
 

 

خوفَ عينٍ وحاسِدِ
 

كُلُوا في بعضِ بطنِكمُ تَعِفُّوا
 

 

فإنّ زمانَكمْ زمنٌ خميصُ
 

لا تَحْظُرِ العَفْوَ إنْ كنتَ امْرَءًا حَرِجًا
 

 

فإنّ حَظْرَكهُ للدِّينِ إزْراءُ
 

لا يَسْألُونَ أخاهُمْ حِينَ يَنْدُبُهُمْ
 

 

للنّائِباتِ عَلَى ما قالَ بُرْهانا
 

لِسانُ الفَتى نِصْفٌ ونِصفٌ فُؤادُه
 

 

فَلَمْ يَبْقَ إلّا صُورةُ اللّحمِ والدّمِ
 

مَساميحُ الفِعالِ ذَوُو أناةٍ
 

 

مراجيحٌ وأوجُهُهُمْ وِضاءُ
 

مَنطِق صائب وتلحَن أحْيانًا
 

 

وخيْرُ الكَلامِ ما كانَ لحنَا
 

وإنْ تَسْألونِي بالنِّساءِ فإنَّني
 

 

خبيرٌ بأدْواءِ النِّساءِ طَبِيبُ
 

وإنّ لسانَ المرءِ ما لم تكنْ له
 

 

حصاةٌ على عَوراتهِ لَدَليلُ
 

وإنّ لِسانَ المَرْء ما لَمْ يَكُنْ لَه
 

 

حَصاةٌ عَلى عَوْراتِه لَدَلِيلُ
 

وإنِّي وإن أوْعَدْتُه أو وعَدْتُهُ
 

 

لمنجزُ إيعادي ومُخْلِفُ مَوْعِدي
 

 

 

وهذه صورته بعد الترتيب:

 لا تَحْظُرِ العَفْوَ إنْ كنتَ امْرَءًا حَرِجًا
 

 

فإنّ حَظْرَكهُ للدِّينِ إزْراءُ
 

 مَساميحُ الفِعالِ ذَوُو أناةٍ
 

 

مراجيحٌ وأوجُهُهُمْ وِضاءُ
 

 لا يَسْألُونَ أخاهُمْ حِينَ يَنْدُبُهُمْ
 

 

للنّائِباتِ عَلَى ما قالَ بُرْهانا
 

 مَنطِق صائب وتلحَن أحْيانًا
 

 

وخيْرُ الكَلامِ ما كانَ لحنَا
 

 عُمَيرةَ ودِّعْ إنْ تَجَهَّزْتَ غادِيا
 

 

كَفَي الشّيْبُ والإسْلامُ لِلْمَرْءِ ناهِيا
 

 سَراةُ بَني أبي بَكْرٍ تَسامَوْا
 

 

عَلَى كانَ المُسَوَّمةِ العِرابِ
 

 وإنْ تَسْألونِي بالنِّساءِ فإنَّني
 

 

خبيرٌ بأدْواءِ النِّساءِ طَبِيبُ
 

 قلّدوها تمائمًا
 

 

خوفَ عينٍ وحاسِدِ
 

 كُلُوا في بعضِ بطنِكمُ تَعِفُّوا
 

 

فإنّ زمانَكمْ زمنٌ خميصُ
 

 رُبَّ مَنْ أنضَجتُ غيظًا قلبَهُ
 

 

قد تمنَّى لي موتًا لم يُطَعْ
 

 رُبَّما تَكْرَهُ النُّفُوسُ من الأمْر
 

 

ما لَهُ فَرْجةٌ كَحَلِّ العِقالِ
 

 وإنّ لسانَ المرءِ ما لم تكنْ له
 

 

حصاةٌ على عَوراتهِ لَدَليلُ
 

 وإنّ لِسانَ المَرْء ما لَمْ يَكُنْ لَه
 

 

حَصاةٌ عَلى عَوْراتِه لَدَلِيلُ
 

 لِسانُ الفَتى نِصْفٌ ونِصفٌ فُؤادُه
 

 

فَلَمْ يَبْقَ إلّا صُورةُ اللّحمِ والدّمِ
 

 وإنِّي وإن أوْعَدْتُه أو وعَدْتُهُ
 

 

لمنجزُ إيعادي ومُخْلِفُ مَوْعِدي
 

Link to post
Share on other sites
  • 1 month later...

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

Link to post
Share on other sites

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

Link to post
Share on other sites

Join the conversation

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

Guest
Reply to this topic...

×   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.

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...