إلغاء الدمج والتعبئة

[gorh]

ارجوا المساعدة
ـ إلغاء الدمج مع التعبئة 
ـ توحيد التأريخ بناء على first date

ـ مرفق صورة لتوضيح المشكلة

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

لا يمكن العمل على الصورة

ارفاق الملف نفسه (او نموذج بسيط عنه اذا كان كبيراً)يمكن وضع اسماء مسنعارة    A/B/C/...

[gorh]

اشكرك استاذ سليم 
مرفق لك الملف 
لكم مني كل الشكر والاحترام والتقدير
وفقكم الله 
وانتظر مساعدتك

ملف إلغاء الدمج والتعبئة.xlsx

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

جرب هذا الكود

Option Explicit
Sub Unmerg_cells()
If ActiveSheet.Name <> "ورقة1" Then Exit Sub
Dim lr#, i#
Dim My_rg As Range, x, y, z, n
Dim My_min
lr = Cells(Rows.Count, "D").End(3).Row

For i = 2 To lr
    If Cells(i, 2).MergeCells Then
     x = Cells(i, 1)
     y = Cells(i, 2)
     z = Cells(i, 3)
     n = Cells(i, 2).MergeArea.Rows.Count
     Cells(i, 1).UnMerge
     Cells(i, 1).Resize(n) = x
     
     Cells(i, 2).UnMerge
     Cells(i, 2).Resize(n) = y
     
     Cells(i, 3).UnMerge
     Cells(i, 3).Resize(n) = z
     
     My_min = Application.Min(Range("d" & i).Resize(n))
     Range("d" & i).Resize(n) = Format(My_min, "d/m/yyy")
     i = i + n - 1
    End If
 Next
End Sub

الملف مرفق

 

Gorh.xlsm

[gorh]

استاذ سليم 
أسأل الله أن يوفقك جــزاك الله كل خير 
الكود رائع جدا جدا 
ملاحظه بسيطه 
اذا كانت القيم ضمن خلية واحدة وليست مدمجة 
انظر الملف المرفق
 

DATA2.xlsx

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

الماكرو يتعاطى مع الخلايا المدمجة في اول ثلاثة اعمدة فقط 

الخلابا العادية ليس لها شأن

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

و هذا ملف يمكنك منه خلاله الاختيار دمج الخلايا  او  عدم دمجها 

زر لكل اختيار (على 3 أعمدة (يمكن الاضافة قدر ما تريد)

Option Explicit
Sub Unmerg_cells()
Application.ScreenUpdating = False
If ActiveSheet.Name <> "Test" Then GoTo End_Me
Dim lr#, i#
Dim My_rg As Range, x, y, z, n
Dim My_min
lr = Cells(Rows.Count, "A").End(3).Row

For i = 2 To lr
    If Cells(i, 1).MergeCells Then
     x = Cells(i, 1)
     y = Cells(i, 2)
     z = Cells(i, 3)
     n = Cells(i, 1).MergeArea.Rows.Count
     Cells(i, 1).UnMerge
     Cells(i, 1).Resize(n) = x
     
     Cells(i, 2).UnMerge
     Cells(i, 2).Resize(n) = y
     
     Cells(i, 3).UnMerge
     Cells(i, 3).Resize(n) = z
     i = i + n - 1
    End If
 Next
End_Me:
 Range("A1").Select
 Application.ScreenUpdating = True
End Sub
'++++++++++++++++++
Sub merge_all()
Application.ScreenUpdating = False
If ActiveSheet.Name <> "Test" Then GoTo End_Me
 Dim k%
  For k = 1 To 3
    Call One_for_all(k)
  Next
   With Range("A1").CurrentRegion
   .Font.Size = 14
   .Font.Bold = True
   End With
End_Me:
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++++

Sub One_for_all(ByVal Col As Integer)
Application.DisplayAlerts = False
Dim i%, lr%, My_rg As Range
Dim x
lr = Cells(Rows.Count, Col).End(3).Row
Set My_rg = Cells(1, Col)
 For i = 1 To lr
      x = Cells(i, Col).Value
    If My_rg.Cells(1).Value = x Then
       Set My_rg = Union(My_rg, Cells(i, Col))
      My_rg.MergeCells = True
    Else
      Set My_rg = Cells(i, Col)
    End If
 Next
Application.DisplayAlerts = True
End Sub

الملف مرفق

 

 

Merge_Unmerge_rows_Multiple_colmns.xlsm

[gorh]

الله يوفقك يا استاذ سليم 
الف الف الف مليون شكرا لكم جميعـا