我可以向您推荐以下代码:
Sub Merge()
Dim k As Range, cell As Range, name As String
Set k = Range("C13:C50")
Application.DisplayAlerts = False
Do_it_again:
For Each cell In k
If cell.Value = cell.Offset(1, 0).Value _
And IsEmpty(cell) = False Then
Debug.Print cell.Address
'for column C
Range(cell, cell.Offset(1, 0)).Merge
'for column B
cell.Offset(0, -1).Resize(cell.MergeArea.Rows.Count, 1).Merge
'for column D
cell.Offset(0, 1).Resize(cell.MergeArea.Rows.Count, 1).Merge
GoTo Do_it_again
End If
Next
Application.DisplayAlerts = True
End Sub
我不需要喜欢我提出的代码,但毕竟它的工作原理如下所示。
编辑以提高效率
我不得不承认以前的代码对于大数据表效率不高,比如 5000 行或更多。下面的一个要快 90%,但对于 5000 行数据仍然需要大约 10-20 秒。
与上面的代码相比,最重要的更改标记为 *****。
Sub Merge()
Dim k As Range, cell As Range, name As String
Dim kStart As Range, kEnd As Range '*****
Set kStart = Range("C13") '*****
Set kEnd = Range("C8000") '*****
Application.DisplayAlerts = False
Application.ScreenUpdating = False '*****
Do_it_again:
For Each cell In Range(kStart, kEnd) '*****
If cell.Value = cell.Offset(1, 0).Value _
And IsEmpty(cell) = False Then
Application.StatusBar = cell.Address '***** check progress in Excel status bar
'for column C
Range(cell, cell.Offset(1, 0)).Merge
'for column B
cell.Offset(0, -1).Resize(cell.MergeArea.Rows.Count, 1).Merge
'for column D
cell.Offset(0, 1).Resize(cell.MergeArea.Rows.Count, 1).Merge
Set kStart = cell '*****
GoTo Do_it_again
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True '*****
End Sub