实现功能如下：
excel指定行列范围内的所有单元格
规则1：每一列的连续相同的值合并单元格
规则2：每一列的第一个非空单元格与其下方的所有空白单元格合并单元
规则3：优先左侧列合并单元格，合并后，右侧的单元格的合并范围的行上下限不能超过左侧的单元格范围。
如下图：
Sub MergeCellsBetweenNonEmpty()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名称
Dim startRow As Long, endRow As Long
Dim startCol As Long, endCol As Long
startRow = 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 Long
Dim firstNonEmptyRow As Long, secondNonEmptyRow As Long
Dim hasNonEmptyCell As Boolean
Dim mergeArea As Range
' 禁用屏幕更新和自动计算以提高性能
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False ' 禁用警告提示
' 循环遍历每一列
For j = startCol To endCol
firstNonEmptyRow = 0
secondNonEmptyRow = 0
hasNonEmptyCell = False
' 循环遍历每一行，查找所有符合条件的第一对非空单元格
For i = startRow To endRow
If ws.Cells(i, j).Value <> "" Then
If firstNonEmptyRow = 0 Then
firstNonEmptyRow = i ' 找到第一个非空单元格
ElseIf secondNonEmptyRow = 0 Then
secondNonEmptyRow = i ' 找到第二个非空单元格
' 如果两个非空单元格之间有其他单元格，则尝试合并
If secondNonEmptyRow - firstNonEmptyRow > 1 Then
' 计算右侧列的合并范围
Dim rightMergeStart As Long, rightMergeEnd As Long
rightMergeStart = firstNonEmptyRow
rightMergeEnd = secondNonEmptyRow - 1
' 检查左侧列的合并范围
Dim leftMergeStart As Long, leftMergeEnd As Long
If j > startCol Then
On Error Resume Next
Set mergeArea = ws.Cells(rightMergeStart, j - 1).MergeArea
On Error GoTo 0
If Not mergeArea Is Nothing Then
leftMergeStart = mergeArea.Row
leftMergeEnd = leftMergeStart + mergeArea.Rows.Count - 1
Else
leftMergeStart = ws.Cells(rightMergeStart, j - 1).Row
leftMergeEnd = leftMergeStart
End If
' 计算重叠区域
Dim overlapStart As Long, overlapEnd As Long
overlapStart = WorksheetFunction.Max(rightMergeStart, leftMergeStart)
overlapEnd = WorksheetFunction.Min(rightMergeEnd, leftMergeEnd)
' 如果存在重叠区域且行数大于1，则合并
If overlapStart <= overlapEnd And (overlapEnd - overlapStart + 1) > 1 Then
With ws.Range(ws.Cells(overlapStart, j), ws.Cells(overlapEnd, j))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
Else
' 第一列直接合并（检查行数是否大于1）
If (rightMergeEnd - rightMergeStart + 1) > 1 Then
With ws.Range(ws.Cells(rightMergeStart, j), ws.Cells(rightMergeEnd, j))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
End If
' 重置 firstNonEmptyRow 和 secondNonEmptyRow，继续查找下一对
firstNonEmptyRow = secondNonEmptyRow
secondNonEmptyRow = 0
End If
hasNonEmptyCell = True
End If
Next i
' 如果找到第一个非空单元格但未找到第二个非空单元格，则尝试合并到最后一行的单元格
If firstNonEmptyRow > 0 And secondNonEmptyRow = 0 Then
If endRow - firstNonEmptyRow > 0 Then
' 计算右侧列的合并范围
rightMergeStart = firstNonEmptyRow
rightMergeEnd = endRow
' 检查左侧列的合并范围
If j > startCol Then
On Error Resume Next
Set mergeArea = ws.Cells(rightMergeStart, j - 1).MergeArea
On Error GoTo 0
If Not mergeArea Is Nothing Then
leftMergeStart = mergeArea.Row
leftMergeEnd = leftMergeStart + mergeArea.Rows.Count - 1
Else
leftMergeStart = ws.Cells(rightMergeStart, j - 1).Row
leftMergeEnd = leftMergeStart
End If
' 计算重叠区域
overlapStart = WorksheetFunction.Max(rightMergeStart, leftMergeStart)
overlapEnd = WorksheetFunction.Min(rightMergeEnd, leftMergeEnd)
' 如果存在重叠区域且行数大于1，则合并
If overlapStart <= overlapEnd And (overlapEnd - overlapStart + 1) > 1 Then
With ws.Range(ws.Cells(overlapStart, j), ws.Cells(overlapEnd, j))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
Else
' 第一列直接合并（检查行数是否大于1）
If (rightMergeEnd - rightMergeStart + 1) > 1 Then
With ws.Range(ws.Cells(rightMergeStart, j), ws.Cells(rightMergeEnd, j))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
End If
End If
' 如果该列没有非空单元格或全部是非空单元格，则不合并
If Not hasNonEmptyCell Or (firstNonEmptyRow = startRow And secondNonEmptyRow = 0) Then
GoTo NextColumn
End If
NextColumn:
Next j
' 新增规则：合并相邻相同内容的单元格
For j = startCol To endCol
For i = startRow To endRow
If ws.Cells(i, j).Value <> "" Then
Dim mergeStart As Long
mergeStart = i
' 检查当前单元格与下一行单元格内容是否相同
Do While i < endRow And ws.Cells(i + 1, j).Value = ws.Cells(mergeStart, j).Value
i = i + 1
Loop
' 如果合并范围的行数大于1，则合并
If i > mergeStart Then
With ws.Range(ws.Cells(mergeStart, j), ws.Cells(i, j))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
Next i
Next j
' 恢复屏幕更新和自动计算
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True ' 恢复警告提示
MsgBox "合并完成！"
End Sub