相同内容合并并居中对齐

zhangbuliang

一列相同内容合并居中对齐

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a1:a" & r)
   
9.         For i = UBound(arr) - 1 To 2 Step -1
   
10.             If arr(i, 1) = arr(i + 1, 1) Then
    
11.                 .Cells(i, 1).Resize(2, 1).Merge
    
12.             End If
    
13.         Next
    
14.     End With
    
15. End Sub
    

复制代码

chxw68

详见附件。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.DisplayAlerts = False
    With Sheet1
        For i = .Cells(Rows.Count, 1).End(3).Row To 3 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                With .Range(.Cells(i, 1), .Cells(i - 1, 1))
                    .Merge
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
            End If
        Next
    End With
    Beep
    Application.DisplayAlerts = True
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

合并单元格

1. Sub ykcbf()   '//2024.9.14
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     For i = r To 2 Step -1
   
6.         Set Rng = Cells(i, 1)
   
7.         Set Rng1 = Rng.Offset(-1)
   
8.         If Rng = Rng1 Then
   
9.             Cells(i, 1).Offset(-1).Resize(2).Merge
   
10.         End If
    
11.     Next
    
12.     Application.ScreenUpdating = True
    
13.     Application.DisplayAlerts = True
    
14.     MsgBox "OK！"
    
15. End Sub
    
16. 
    

复制代码

xlj310

如果数据量只有3、5百行， 那上面这些都可以做。
如果数据量有几千几万行，最好是考虑一下效率。
我就给个思路~

lizhipei78

xlj310 发表于 2024-9-15 14:42
如果数据量只有3、5百行， 那上面这些都可以做。
如果数据量有几千几万行，最好是考虑一下效率。
我就给 ...

代码略显复杂，我是这样子搞的，没有针对楼主案例

ykcbf1100

如果合并数据多时，改用数组，速度会快许多。