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

[بلانك]

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

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

 

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

[بلانك]

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

[بلانك]

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

[Foksh]

🤔

يعني تريد ألغاء الدمج للخلايا التي تم دمجها ، مع إعادة القيم لكل خلية !!!

تمام ، جرب هذا الماكرو أ واستعمله في حدث عند النقر لأي زر مثلاً :-

Sub UnMergeFoksh()
    Dim ws As Worksheet
    Dim r As Long, c As Long
    Dim mArea As Range
    Dim cellText As String
    
    Set ws = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    For r = 4 To 20
        For c = 2 To 36
            
            If ws.Cells(r, c).MergeCells Then
                Set mArea = ws.Cells(r, c).MergeArea
                cellText = ws.Cells(r, c).Text
                mArea.UnMerge
                mArea.NumberFormat = "@"
                mArea.Value = "'" & cellText
                mArea.HorizontalAlignment = xlCenter
                mArea.VerticalAlignment = xlCenter
            End If
        Next c
    Next r
    
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

طبعاً اعتقد انك هنا ستستغني عن حدث عند التغيير للورقة السابق .. ويصبح ملفك كالتالي للحدثين مع إضافة زرين .

 

merge cell.xlsm

[بلانك]

بارك الله فيك تمام جزاك الله كل خير..... ورمضان كريم