单元格按照层级合并问题！并交朋友做个小项目。

yanghang29

如图，层级分为6级，但最右一列不需要合并。A列从A2开始向下合并，同下面所有空值单元格合并（合并至下部有文本单元格上面一行空单元格）。然后又从有文本的单元格开始新得合并，直至算选区域结尾行。B列从B3开始，也是依次合并到所选区域结尾行。C、D、E列开始位置依次有规律下移一行，都是至结尾行。请大神帮忙用VBA实现自动合并。
我自己总结的合并规律是这样的：所有列的合并范围受其自身列下部有文本单元格的约束，同时受其所有左侧列有文本单元格的约束。即任何一列有文本的单元格向下合并，必须满足的条件的条件是：从有文本的单元格到最左列（也就是A列）向左、向下围城的矩形区域内只能有一个有文本单元格，也就是非空单元格计数为1。如果矩形区域内非空单元格计数超过1，合并单元格范围就只能到向上一行（也是计数为1的最下面一行）。如此循环判断，直至结尾行。这个规律同时适用A列和不需要合并的最后一列。


另外：想结交朋友，做一个用Exel自动划考勤的项目。感觉网上的那些考勤表都不太实用。自己做的是自动划半天考勤。自动划考勤，自动计算考勤。只需要数据输入休假的类型和日期，自动划考勤。能生成每月考勤，还能追踪一年内每个人的考勤情况。基本想法已经有了，有志同道合的朋友可以一起来。

yanghang29

忘了上传示意附件了。请大家下载。

3190496160

Sub hebing()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
    m = 2
    r = .Cells(Rows.Count, 6).End(xlUp).Row
    For j = 1 To 5
        zf = ""
        For i = m To r
            If Trim(.Cells(i, j)) <> "" Then
                If zf = "" Then
                    zf = i
                Else
                    zf = zf & "," & i
                End If
            End If
        Next i
        zf = zf & "," & r + 1
        rr = Split(zf, ",")
        For i = 0 To UBound(rr) - 1 Step 1
            .Range(.Cells(rr(i), j), .Cells(rr(i + 1) - 1, j)).Merge
        Next i
    Next j
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

代码审核中，耐心等待吧，

yanghang29

3190496160 发表于 2020-8-30 08:38
Sub hebing()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

先谢谢！晚上测试。

2912770391

初学者，用excel的理解方式拆分的代码。
Sub hebing()

Set wb = ThisWorkbook
arr = wb.Sheets(1).UsedRange
rw = UBound(arr)
For i = 2 To rw
    t = wb.Sheets(1).Cells(i, 1).End(xlDown).Row - 1
    If t > rw Then
        t = rw
    End If
    wb.Sheets(1).Range(Cells(i, 1), Cells(t, 1)).Select
    Selection.Merge
   
    For m = i + 1 To t
        t1 = wb.Sheets(1).Cells(m, 2).End(xlDown).Row - 1
        If t1 > t Then
            t1 = t
        End If
        wb.Sheets(1).Range(Cells(m, 2), Cells(t1, 2)).Select
        Selection.Merge
        
        For m2 = m + 1 To t1
            t2 = wb.Sheets(1).Cells(m2, 3).End(xlDown).Row - 1
            If t2 > t1 Then
                t2 = t1
            End If
            wb.Sheets(1).Range(Cells(m2, 3), Cells(t2, 3)).Select
            Selection.Merge
            
            For m3 = m2 + 1 To t2
                t3 = wb.Sheets(1).Cells(m3, 4).End(xlDown).Row - 1
                If t3 > t2 Then
                    t3 = t2
                End If
                wb.Sheets(1).Range(Cells(m3, 4), Cells(t3, 4)).Select
                Selection.Merge
               
                For m4 = m3 + 1 To t3
                    t4 = wb.Sheets(1).Cells(m4, 5).End(xlDown).Row - 1
                    If t4 > t3 Then
                        t4 = t3
                    End If
                    wb.Sheets(1).Range(Cells(m4, 5), Cells(t4, 5)).Select
                    Selection.Merge
                    
                    m4 = t4
                Next m4
               
                m3 = t3
            Next m3
            
            m2 = t2
        Next m2
        
        m = t1
    Next m
    i = t
Next i
wb.Sheets(1).Range(Cells(2, 1), Cells(t, 6)).Select
With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
End With
End Sub

准提部林

Sub TEST()
Dim R&, xR As Range, xH(1 To 6) As Range, xE As Range, j%
R = [F65536].End(xlUp).Row
For Each xR In Range("A2:A" & R + 1)
    For j = 1 To 6
        If xR(1, j) <> "" Then Set xH(j) = xR(1, j)
    Next j
    If xH(6) Is Nothing Then GoTo 101
    For j = 1 To 5
        If xR(2, j) <> "" Or xR.Row = R Then Range(xH(j), xH(6)(1, j - 5)).Merge
    Next j
101: Next
End Sub

yanghang29

3190496160 发表于 2020-8-30 08:39
代码审核中，耐心等待吧，

合并有误，

yanghang29

准提部林 发表于 2020-8-30 12:06
Sub TEST()
Dim R&, xR As Range, xH(1 To 6) As Range, xE As Range, j%
R = [F65536].End(xlUp).Row

简单，管用！高手，膜拜！

yanghang29

2912770391 发表于 2020-8-30 11:51
初学者，用excel的理解方式拆分的代码。
Sub hebing()

你的这个能实现功能，只是速度有点慢，可能运算太多，不过能解决问题，谢谢！