دمج الخلايا المتشابهة في نطاق وإلغاء الدمج

[ياسر خليل أبو البراء]

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

إخواني وأحبابي في الله

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

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

بفرض أن النطاق A1 إلى آخر خلية بها بيانات .. في هذا النطاق خلايا متشابهة في القيمة مثلاً الخلية A1 و A2 و A3 بها نفس القيمة وليكن حرف الـ "A" ..الكود التالي يقوم بعملية الدمج لهذه الخلايا

Sub MergeSameCell()
    Dim Rng As Range, xCell As Range
    Dim xRows As Integer
    Set WorkRng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        xRows = WorkRng.Rows.Count
        For Each Rng In WorkRng.Columns
            For i = 1 To xRows - 1
                For j = i + 1 To xRows
                    If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                    Exit For
                    End If
                Next
                WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
                i = j - 1
            Next
        Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

والكود التالي يعكس عملية الدمج ويلغي الدمج الذي تم في خلايا النطاق

Sub UnMergeSameCell()
    Dim Rng As Range, xCell As Range
    Set WorkRng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        For Each Rng In WorkRng
            If Rng.MergeCells Then
                With Rng.MergeArea
                    .UnMerge
                    .Formula = Rng.Formula
                End With
            End If
        Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

أرجو أن يكون الموضوع ذات فائدة للجميع

 

حمل الملف من هنا

 

تقبلوا وافر تقديري واحترامي

أخوكم ياسر خليل أبو البراء

[ياسر خليل أبو البراء]

بارك الله فيكم إخواني المتعلمين .. أما زلتم تريدون التعلم أم اكتفيتم بما وصلتم إليه ...؟!!!

تقبلوا وافر تقديري واحترامي

[أبوبسمله]

لم أكتفى يا ابو البراء فانى مازلت تحت الصفر

جزاك الله خيرا

تقبل تحياتى ياغالى

[ياسر خليل أبو البراء]

وجزيت خيراً أخي الغالي أحمد

مشكور مرورك العطر بالموضوع