VBA 列方向合并单元格，左侧范围大于右侧范围

实现功能如下：
excel指定行列范围内的所有单元格
规则1：每一列的连续相同的值合并单元格
规则2：每一列的第一个非空单元格与其下方的所有空白单元格合并单元
规则3：优先左侧列合并单元格，合并后，右侧的单元格的合并范围的行上下限不能超过左侧的单元格范围。

如下图：

Sub MergeCellsBetweenNonEmpty()Dim ws As WorksheetSet ws = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名称Dim startRow As Long, endRow As LongDim startCol As Long, endCol As LongstartRow = 1 ' 起始行号endRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' 动态获取结束行号startCol = 1 ' 起始列号endCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' 动态获取结束列号Dim i As Long, j As LongDim firstNonEmptyRow As Long, secondNonEmptyRow As LongDim hasNonEmptyCell As BooleanDim mergeArea As Range' 禁用屏幕更新和自动计算以提高性能Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.DisplayAlerts = False ' 禁用警告提示' 循环遍历每一列For j = startCol To endColfirstNonEmptyRow = 0secondNonEmptyRow = 0hasNonEmptyCell = False' 循环遍历每一行，查找所有符合条件的第一对非空单元格For i = startRow To endRowIf ws.Cells(i, j).Value <> "" ThenIf firstNonEmptyRow = 0 ThenfirstNonEmptyRow = i ' 找到第一个非空单元格ElseIf secondNonEmptyRow = 0 ThensecondNonEmptyRow = i ' 找到第二个非空单元格' 如果两个非空单元格之间有其他单元格，则尝试合并If secondNonEmptyRow - firstNonEmptyRow > 1 Then' 计算右侧列的合并范围Dim rightMergeStart As Long, rightMergeEnd As LongrightMergeStart = firstNonEmptyRowrightMergeEnd = secondNonEmptyRow - 1' 检查左侧列的合并范围Dim leftMergeStart As Long, leftMergeEnd As LongIf j > startCol ThenOn Error Resume NextSet mergeArea = ws.Cells(rightMergeStart, j - 1).MergeAreaOn Error GoTo 0If Not mergeArea Is Nothing ThenleftMergeStart = mergeArea.RowleftMergeEnd = leftMergeStart + mergeArea.Rows.Count - 1ElseleftMergeStart = ws.Cells(rightMergeStart, j - 1).RowleftMergeEnd = leftMergeStartEnd If' 计算重叠区域Dim overlapStart As Long, overlapEnd As LongoverlapStart = WorksheetFunction.Max(rightMergeStart, leftMergeStart)overlapEnd = WorksheetFunction.Min(rightMergeEnd, leftMergeEnd)' 如果存在重叠区域且行数大于1，则合并If overlapStart <= overlapEnd And (overlapEnd - overlapStart + 1) > 1 ThenWith ws.Range(ws.Cells(overlapStart, j), ws.Cells(overlapEnd, j)).Merge.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd WithEnd IfElse' 第一列直接合并（检查行数是否大于1）If (rightMergeEnd - rightMergeStart + 1) > 1 ThenWith ws.Range(ws.Cells(rightMergeStart, j), ws.Cells(rightMergeEnd, j)).Merge.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd WithEnd IfEnd IfEnd If' 重置 firstNonEmptyRow 和 secondNonEmptyRow，继续查找下一对firstNonEmptyRow = secondNonEmptyRowsecondNonEmptyRow = 0End IfhasNonEmptyCell = TrueEnd IfNext i' 如果找到第一个非空单元格但未找到第二个非空单元格，则尝试合并到最后一行的单元格If firstNonEmptyRow > 0 And secondNonEmptyRow = 0 ThenIf endRow - firstNonEmptyRow > 0 Then' 计算右侧列的合并范围rightMergeStart = firstNonEmptyRowrightMergeEnd = endRow' 检查左侧列的合并范围If j > startCol ThenOn Error Resume NextSet mergeArea = ws.Cells(rightMergeStart, j - 1).MergeAreaOn Error GoTo 0If Not mergeArea Is Nothing ThenleftMergeStart = mergeArea.RowleftMergeEnd = leftMergeStart + mergeArea.Rows.Count - 1ElseleftMergeStart = ws.Cells(rightMergeStart, j - 1).RowleftMergeEnd = leftMergeStartEnd If' 计算重叠区域overlapStart = WorksheetFunction.Max(rightMergeStart, leftMergeStart)overlapEnd = WorksheetFunction.Min(rightMergeEnd, leftMergeEnd)' 如果存在重叠区域且行数大于1，则合并If overlapStart <= overlapEnd And (overlapEnd - overlapStart + 1) > 1 ThenWith ws.Range(ws.Cells(overlapStart, j), ws.Cells(overlapEnd, j)).Merge.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd WithEnd IfElse' 第一列直接合并（检查行数是否大于1）If (rightMergeEnd - rightMergeStart + 1) > 1 ThenWith ws.Range(ws.Cells(rightMergeStart, j), ws.Cells(rightMergeEnd, j)).Merge.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd WithEnd IfEnd IfEnd IfEnd If' 如果该列没有非空单元格或全部是非空单元格，则不合并If Not hasNonEmptyCell Or (firstNonEmptyRow = startRow And secondNonEmptyRow = 0) ThenGoTo NextColumnEnd IfNextColumn:Next j' 新增规则：合并相邻相同内容的单元格For j = startCol To endColFor i = startRow To endRowIf ws.Cells(i, j).Value <> "" ThenDim mergeStart As LongmergeStart = i' 检查当前单元格与下一行单元格内容是否相同Do While i < endRow And ws.Cells(i + 1, j).Value = ws.Cells(mergeStart, j).Valuei = i + 1Loop' 如果合并范围的行数大于1，则合并If i > mergeStart ThenWith ws.Range(ws.Cells(mergeStart, j), ws.Cells(i, j)).Merge.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd WithEnd IfEnd IfNext iNext j' 恢复屏幕更新和自动计算Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.DisplayAlerts = True ' 恢复警告提示MsgBox "合并完成！"
End Sub