在VBA中合并多行

Question

我正在尝试创建一个简单的子程序，如果列a中的单元格包含相同的数字数据，该子程序将合并多行。

Option Explicit
Sub MergeRows()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
lastRow = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow

If ThisWorkbook.Worksheets(1).Cells(i, 1).Value = _
ThisWorkbook.Worksheets(1).Cells(i + 1, 1).Value Then
ThisWorkbook.Worksheets(1).Range(ThisWorkbook.Worksheets(1) _
.Cells(i, 1), ThisWorkbook.Worksheets(1).Cells(i + 1, 1)).Merge

Else

End If

Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

上面的代码一次只合并2行，所以如果有三行具有相同的值，它会合并两行，然后将一行中的剩余部分留给自己。

Answer 1

我添加了一个While循环，它继续检查相邻单元格是否有相同的值，直到找到不同的值。我还在您的第一个If语句中添加了一个检查，以确保它所比较的值不是空值。

为了便于阅读，我还将图纸引用移到了With块中，这样就不会在整个代码中不必要地重复。

Option Explicit
Sub MergeRows()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long, r As Long
With ThisWorkbook.Worksheets(1)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRow

If .Cells(i, 1).Value <> "" _
And .Cells(i, 1).Value = .Cells(i + 1, 1).Value _
Then
r = 1
While .Cells(i + r, 1) = .Cells(i, 1).Value
r = r + 1
Wend
.Cells(i, 1).Resize(r).Merge
Else

End If

Next i
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

旁注：您可以通过在.Merge之后直接添加一行i = i + r来保存迭代，以将循环推进到下一个未合并的单元格。