المطلوب عند وجود حصتان متتاليان يتم دمجهما معا

[بلانك]

المطلوب عند وجود حصتان 
متتاليان يتم دمجهما معا  كما بالملف

merge cell.xlsx

[Foksh]

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

بداية أعتقد أن التنسيق الشرطي سيكون عقبة ومشكلة كونه - على حد علمي - لا يوم بالدمج للخلايا كما تريد . لذا ؛ لجأت لإستخدام دالة بسيطة كالتالي :-

Sub MergeFokshCells()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dayRanges As Variant
    Dim i As Long, j As Long, startCol As Long
    Dim d As Long
    
    Application.DisplayAlerts = False
    
    Set ws = ActiveSheet
    lastRow = 20
    
    dayRanges = Array(Array(2, 8), Array(9, 15), Array(16, 22), Array(23, 29), Array(30, 36))
    For i = 4 To lastRow
        For d = LBound(dayRanges) To UBound(dayRanges)
            j = dayRanges(d)(0)
            Do While j <= dayRanges(d)(1)
                If ws.Cells(i, j).Value <> "" Then
                    startCol = j
                    Do While j < dayRanges(d)(1) And ws.Cells(i, j).Value = ws.Cells(i, j + 1).Value
                        j = j + 1
                    Loop
                    If j > startCol Then
                        ws.Range(ws.Cells(i, startCol), ws.Cells(i, j)).Merge
                        ws.Cells(i, startCol).HorizontalAlignment = xlCenter
                        ws.Cells(i, startCol).VerticalAlignment = xlCenter
                    End If
                End If
                j = j + 1
            Loop
        Next d
    Next i
    
    Application.DisplayAlerts = True
End Sub

وتستطيع استدعائها بحدث عند التغيير مثلاً داخل الورقة ، بالشكل التالي :-

Private Sub Worksheet_Change(ByVal Target As Range)
    Call MergeFokshCells
End Sub

أو حتى في حدث عند الفتح إن أردت بنفس الأسلوب :-

Private Sub Workbook_Open()
    Call MergeFokshCells
End Sub

 

جرب وأخبرني بالنتيجة ، طبعاً بعد حفظ الملف بصيغة  . جرب دون أرفاقي الملف لتتعرف على النتيجة .

[بلانك]

تمام بارك الله فيك ............ طلب لو اردت عدم الدمج بعد عملية الدمج ؟؟؟؟؟؟؟؟؟؟؟؟؟

[بلانك]

بمعني ارجاع الملف الى اصله قبل الدمج