دمج الخلايا عندما تكون لها نفس القيم

[bachiri401]

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

نور الله لكم طريقكم اخواني بالمنتدى 

اريد المساعدة بكود يقوم بدمج الخلايا عندما تحمل نفس القيم

 

دمج الخلايا عندما تكون لها نفس القيم.xlsx

تم تعديل نوفمبر 17, 2020 بواسطه bachiri401

[سليم حاصبيا]

1- اي نعديلات على الجدول يجب ادراجها في النطاق  AA1:AG16 لأن الماكرو يأخذ البيانات من هناك بالنسبة للـــ UNMERGE

جرب هذا الماكرو (الصفحة  SALIM  من هذا الملف )

Option Explicit

Sub Mreg_equal_cells()
Dim Ro%, i%, k%, t%, n%, ky
Dim d As Object
Dim Rg As Range
Set d = CreateObject("Scripting.Dictionary")
Ro = Cells(Rows.Count, 1).End(3).Row

For t = 2 To 7
k = 1
Do Until k > Ro
  i = k: n = 1
      Do Until Cells(i, t) <> Cells(i + 1, t)
        n = n + 1
        i = i + 1
      Loop
    Set Rg = Cells(k, t).Resize(n)
    d(Rg.Address) = ""
    k = k + n
Loop

    Application.DisplayAlerts = False
        For Each ky In d.keys
        Range(ky).Merge
        Next
    Application.DisplayAlerts = True

d.RemoveAll
Next

Application.DisplayAlerts = True
End Sub
'+++++++++++++++++++

Sub No_merge()
 Range("AA1:AG16").Copy Range("A1")
    
End Sub

الملف مرفق الصفحة  SALIM 

bachiri401_MERGE.xlsm

[وجيه شرف الدين]

بعد اذن استاذنا سليم واثراء للموضوع انظر الى هذا المرفق

نسخة من دمج الخلايا عندما تكون لها نفس القيم-1.xlsm

[سليم حاصبيا]

رائع استاذ وجيه  

باقي كود لأرجاع كل شيء كما كان

 بعد اذنك بلاش الـــ Select دي التي لا فائدة منها

 

Sub aa()
Application.DisplayAlerts = False
Dim i, J As Integer
For J = 1 To 16
    For i = 2 To 7
      If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _
        And Cells(J, i + 1) <> "" Then
        Range(Cells(J, i), Cells(J, i + 1)).Merge
      End If
    Next
Next
Application.DisplayAlerts = True
End Sub

 

 

[وجيه شرف الدين]

دائما نتعلم منكم استاذ سليم وجزاكم الله خير الجزاء

[abouelhassan]

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

والاستاذ الفاضل وجيه

[سليم حاصبيا]

كود لأرجاع كل شيء كما كان

Option Explicit

Sub UNMERG()
Dim x%, y%, Cel As Range
    With Range("A1").CurrentRegion
        For Each Cel In .Cells
            x = Cel.MergeArea.Rows.Count
            y = Cel.MergeArea.Columns.Count
            Cel.UnMerge
            Cel.Resize(x, y) = Cel.Cells(1, 1).Value
        Next
    .Borders.LineStyle = 1
    End With
End Sub

 

[وجيه شرف الدين]

شكرا استاذنا الفاضل على مرورك العطر وبالنسبة لنفطةالغاء الدمج اتفضل الشيت بعد التعديل

نسخة من دمج الخلايا عندما تكون لها نفس القيم-1.xlsm

ماشاء الله استاذ سليم دائما سباق بالخير جعله الله فى ميزان حسناتك

[سليم حاصبيا]

الكود لا يعطي الا أول حلية من ما كان مدمجاً

 

[وجيه شرف الدين]

الكود يلغى الغاء دمج الخليه التى تقف عليها

[سليم حاصبيا]

(الكود يلغى الغاء دمج الخليه التى تقف عليها)
 اعرف هذا و لكن فيل الدمج مثلا كانت الخلية  B10  و C10 تساويان "رياضيات"

بعد الغاء الدمح الخلية  B10  و حدها  "رياضيات"

[bachiri401]

بارك الله فيكم جميعا إخواني

وجعل كل اعمالكم في ميزان حسناتكم

بارك الله فيكم 

[سليم حاصبيا]

ممكن اوي

Option Explicit
Dim Ro%, i%, J%, x%, y%
Dim Rg As Range, Cel As Range
'+++++++++++++++++++

Sub No_merge()
If ActiveSheet.Name <> "Salim" Then GoTo Fin
 
    With Range("A1").CurrentRegion
        For Each Cel In .Cells
        If Cel.MergeCells Then
            x = Cel.MergeArea.Rows.Count
            y = Cel.MergeArea.Columns.Count
            Cel.UnMerge
            Cel.Resize(x, y) = Cel.Cells(1, 1).Value
         End If
        Next
    .Borders.LineStyle = 1
    End With
Fin:
End Sub
'+++++++++++++++++++++++++++++++
Sub Merge_Please()
If ActiveSheet.Name <> "Salim" Then GoTo Fin

Application.DisplayAlerts = False
x = Range("A1").CurrentRegion.Rows.Count
y = Range("A1").CurrentRegion.Columns.Count

 For J = 1 To x
    For i = 1 To y
      If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _
        And Cells(J, i + 1) <> "" Then
        Range(Cells(J, i), Cells(J, i + 1)).Merge
      End If
    Next
Next
Fin:
Application.DisplayAlerts = True
End Sub

الملف مرفق

bachiri_MERGE_Unmerge.xlsm

[bachiri401]

رائع ربي يجازيك كل ما تتمنى

قمة الروعة كلمات الشكر وحها لا تكفي

ادعو الله ان يزيدك علما و  يرزقك الجنة 

[deolsunny533]

Thanks for the clarification.