طلب كود حذف الأسطر المتشابهة والفارغة

[حامل المسك]

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

وأسعد الله أوقاتكم بالخيرات والمسرات،،

كرما أريد كود أضعه في الوورد بحيث يقوم بحذف الأسطر المتشابهة والفارغة،،

مع جزيل الشكر،،

[شحادة بشير]

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

هل تقصد بالأسطر الفقرات؟

أي هل تريد حذف الفقرات الفارغة؟ وكذلك حذف الفقرات المتشابهة؟

[حامل المسك]

أسعدك الله وأعتذر ،،نعم مثل ما تفضلت به لكني أخطأت في اللفظ،،

 

[شحادة بشير]

ماكرو حذف الفقرات الفارغة:

Sub DeleteParagraphsEmpty()
For Each tempParagraphs In ActiveDocument.Paragraphs
    If Len(tempParagraphs.Range.Text) = 1 Then
       tempParagraphs.Range.Delete
    End If
Next
End Sub

 

وهذا الماكرو يقوم بتحديد الفقرات المتشابهة بلون مختلف؛ لتقوم بعد ذلك بالنظر إليها وحذفها:

Sub HighlightParagraphs()
    Dim I, J As Long
    Dim xRngFind, xRng As Range
    Options.DefaultHighlightColorIndex = wdYellow
    With ActiveDocument
        For I = 1 To .Paragraphs.Count - 1
            Set xRngFind = .Paragraphs(I).Range
            If xRngFind.HighlightColorIndex <> wdYellow Then
                For J = I + 1 To .Paragraphs.Count
                    Set xRng = .Paragraphs(J).Range
                    If xRngFind.Text = xRng.Text Then
                        xRngFind.HighlightColorIndex = wdBrightGreen
                        xRng.HighlightColorIndex = wdYellow
                    End If
                Next
            End If
        Next
    End With
End Sub

لا تنسانا من دعواتك

تم تعديل نوفمبر 23, 2021 بواسطه شحادة بشير

[حامل المسك]

ما شاء الله مبدع أخي شحادة رضي الله عنك وأرضاك،،

هل يمكن تعديل حذف الفقرات إلى حذف الفقرات المكررة المتتالية لأنه لدي مستندات بها فقرات متشابهة وأريده أن يحذف أي فقراتين متتاليتين يحذف أحدهما فقط والتي ليست متتالية لا يحذفها

فعلي سبيل المثال

محمد علي

محمد علي

طلال خالد

محمد علي

فيقوم بحذف واحدة من محمد علي التي في الأولى،،

أرغب في الحذف وليس التلوين أكرمك ورضي عنك وأسعدك،،

[شحادة بشير]

لحذف الفقرات المتشابهة سواء كانت متتالية أو غير متتالية، تفضل هذا الكود:

Sub DeleteDuplicates()
  Dim aRng As Range, aPara As Paragraph, sText As String
  Set aPara = ActiveDocument.Paragraphs.First
  Do While aPara.Range.End <> ActiveDocument.Range.End
    If Len(aPara.Range.Text) > 1 Then
      sText = aPara.Range.Text
      Debug.Print sText
      Set aRng = ActiveDocument.Range
      aRng.Start = aPara.Range.End
      With aRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = sText
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
    End If
    Set aPara = aPara.Next
  Loop
End Sub

وهذا الكود كذلك يقوم بالمهمة السابقة نفسها:

Sub DeleteDuplicateParagraphs()
Dim p1 As Paragraph
Dim p2 As Paragraph
Dim DupCount As Long
DupCount = 0
For Each p1 In ActiveDocument.Paragraphs
    If p1.Range.Text <> vbCr Then 'تجاهل الفقرات الفارغة
       For Each p2 In ActiveDocument.Paragraphs
           If p1.Range.Text = p2.Range.Text Then
              DupCount = DupCount + 1
              If p1.Range.Text = p2.Range.Text And DupCount > 1 Then p2.Range.Delete
           End If
       Next p2
   End If
   'إعادة تعيين عداد مكرر
   DupCount = 0
Next p1
End Sub

 

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

في خانة البحث اكتب:

(*^13)\1

وفي خانة الاستبدال اكتب:

\1

أو يمكنك تنفيذ ذلك من خلال الماكرو التالي:

Sub DeleteDuplicatesParagraph()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(*^13)\1"
        .Replacement.Text = "\1"
        .Forward = True
        .Wrap = wdFindContinue
        .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 Replace:=wdReplaceAll
End Sub

 

بالتوفيق أخي العزيز 🙂

[حامل المسك]

والله إنك مبدع،، والإبداع يتعلم منك،،

شكر الله لك وبارك لك فيما رزقك ووفقك،،

جاري التجربة،،

[JULNAR]

استاذ بشير ىو سمحت اود مراسلتك 

عندي مشكلة بالوورد  لا اجد لها حل