相同内容合并并居中对齐

ykcbf1100

此法更适用于合并数据多的情况。

1. Sub ykcbf()   '//2024.9.16   合并数据多时速度快
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     ReDim zrr(1 To 1000)
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 1)
   
8.         For i = 2 To r
   
9.             If arr(i, 1) <> arr(i - 1, 1) Then m = m + 1: zrr(m) = Array(i, i)
   
10.             If i = r Then zrr(m)(1) = r
    
11.             If i < r Then
    
12.                 If arr(i, 1) = arr(i - 1, 1) And arr(i, 1) <> arr(i + 1, 1) Then zrr(m)(1) = i
    
13.             End If
    
14.         Next
    
15.         For x = 1 To m
    
16.             r1 = zrr(x)(0): r2 = zrr(x)(1)
    
17.             n = r2 - r1 + 1
    
18.            .Cells(r1, 1).Resize(n).Merge
    
19.         Next
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22.     Application.DisplayAlerts = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码