توحيد خلايا العمود اذا كانت تحمل نفس التاريخ

[aspiran]

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

 

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

جرب هذا الملف (نموذج)

تم الاحتقاظ بالبيانات القديمة  في الصفحة  "Copy_Salim"

لاعادة تجربة الماكرو قم اولاً بنسخ البيانات من صفحة"Copy_Salim" الى صفحة "Salim"

الماكرة

Option Explicit

Sub merg_cell()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name <> "Salim" Then GoTo 1
Dim i%, my_rg As Range, k%
Range("a:a").UnMerge
i = 2
Do Until Cells(i, 1) = ""
 k = Application.CountIf(Range("a:a"), Cells(i, 1))
 Range(Cells(i, 1), Cells(i + k - 1, 1)).Merge
 Range(Cells(i, 1), Cells(i + k - 1, 1)).HorizontalAlignment = xlCenter
  Range(Cells(i, 1), Cells(i + k - 1, 1)).VerticalAlignment = xlCenter
 i = i + k
  Loop
1:
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

الملف مرفق

 

Merge_cells.rar

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

دمج الخلايا المتشابهة مع خيار التراجع(مع ان التراجع عن امر نفذ بواسطة الماكرو مستحيل)

لكن لا مستحيل في الـ VBA

الماكرو

Option Explicit

Sub merg_cell()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name <> "Salim" Then GoTo 1
Dim i%, my_rg As Range, k%

i = 2
Do Until Cells(i, 1) = ""
 k = Application.CountIf(Range("a:a"), Cells(i, 1))
        With Range(Cells(i, 1), Cells(i + k - 1, 1))
            .Merge
            .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
         End With
 i = i + k
  Loop
1:
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub


Sub Unmerge_Salim()
Dim numrow, n As Long, t%, x%, k%, cc%
Dim lrxfd%, y%
If ActiveSheet.Name <> "Salim" Then Exit Sub
On Error Resume Next
n = 2
Do Until Range("a" & n) = vbNullString
If Range("a" & n).MergeCells Then cc = 1:  Exit Do
n = n + 1
Loop
If cc = 0 Then MsgBox "No Mergrd cells In this range": Exit Sub
numrow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Range("xfd:xfd").ClearContents

k = 0 ' number of meged areas
n = 2 ' begenning of loop
Do Until Range("a" & n) = vbNullString
    If Range("a" & n).MergeCells Then
        t = Range("a" & n).MergeArea.Count
            Range("xfd" & n) = Range("a" & n)
            For x = 1 To t - 1
            Range("xfd" & n).Offset(x, 0) = Range("xfd" & n)
            Next
            k = k + 1
        Else
        t = 1
        Range("xfd" & n) = Range("a" & n)
    End If
    n = n + t
Loop
lrxfd = Cells(Rows.Count, "xfd").End(3).Row
Range("a:a").UnMerge
Range("a2").Resize(lrxfd - 1).Value = Range("xfd2").Resize(lrxfd - 1).Value
Range("xfd:xfd").ClearContents
 If k <> 0 Then MsgBox "There was :" & k & " merged Areas"
End Sub

 

Merge_Unmerge_cells.rar

[aspiran]

شكرا على المساعدة ياجماعة .... بارك الله فيكم .... الماكرو قيد التجريب