AutoMergeCenter.bas

Sub AutoMergeCenter() 'lệnh Tự động trộn ô và căn giữa
'Updateby2018.10.18
'Thiết lập các biến
Dim Rng As Range
Dim xRows As Integer
Dim WorkRng As Range
Dim i As Integer, j As Integer

Set WorkRng = Selection 'Vùng được chọn
xRows = WorkRng.Rows.Count  'Biến xác định số dòng của vùng được chọn, là giới hạn phạm vi vòng lặp
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Vòng lặp thực hiện trộn các ô liền kề giống nhau
 For Each Rng In WorkRng.Columns 'Xét trên từng cột của vùng được chọn
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
              Exit For  'Thoát vòng lặp khi giá trị trên cùng 1 dòng không giống nhau
            End If
        Next
        'Thực hiện trộn vùng dữ liệu có giá trị giống nhau
        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
        i = j - 1
    Next
Next
WorkRng.VerticalAlignment = xlCenter  'Căn giữa cho vùng được chọn

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