Excel VBA，如何垂直和水平合并或合并具有相同值的单元格？

Question

我在相邻单元格中有相同数据的工作表，我可以合并 A 列上的相同单元格。现在我需要合并或合并 A 列上合并单元格旁边的相邻相同单元格，这意味着如果 A2:A3 相同，则将被合并，随后合并 B2:B3,C2:C3, D2:D3 直到 L 列。

更新：除 Merge 之外的任何方法也都可以

Sub Merge_Similar_Cells()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim WorkRng As Range
    
    Set ws = ActiveSheet
    
    ws.AutoFilter.ShowAllData
    ws.AutoFilter.Sort.SortFields.Clear
    
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
     
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply
                                                                                     
    Set WorkRng = ws.Range("A2:A" & LastRow)

CheckAgain:
    For Each cell In WorkRng
        If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
            Range(cell, cell.Offset(1, 0)).Merge
            cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

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

Answer 1

请测试下一个代码：

Sub Merge_Similar_Cells()
    Dim LastRow As Long, ws As Worksheet, arrWork, i As Long, j As Long, k As Long
    
    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
        ws.AutoFilter.ShowAllData
        ws.AutoFilter.Sort.SortFields.Clear
    End If
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
     
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply
                                                                                     
    arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
    
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1            'iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'determine how many consecutive similar rows exist:_________
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '____________________________________________________
            For j = 1 To 12
                ws.Range(ws.Cells(i, j), ws.Cells(i + k, j)).Merge 'merge all the necessary cells based on previously determined k
           Next j
           ws.Range(ws.Cells(i, 1), ws.Cells(i + k, 12)).VerticalAlignment = xlCenter 'apply vertical alignment for all obtained merged row
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub

编辑：

请尝试下一个代码，它不会在同一列上合并相似的行。 它删除相似的行，只保留一个和 append 范围“M:P”中的单元格值，由vbLf （放置在同一单元格中的单独行）：

Sub DeleteSimilarRows_AppendLastColuns()
    Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
    Dim strVal As String, m As Long, boolNoFilter As Boolean
    
    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then             'for the case when the sheet range is not filtered
        ws.AutoFilter.ShowAllData
        ws.AutoFilter.Sort.SortFields.Clear
        
        LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: boolNoFilter = True
        
        ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ws.AutoFilter.Sort.Apply
    End If
    
     If Not boolNoFilter Then LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
    
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1                  'iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'determine how many consecutive similar rows exist:______
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '_________________________________________
            For j = 13 To 16                  'build the concatenated string of cells in range "M:P":
                strVal = ws.Cells(i, j).Value
                For m = 1 To k
                    strVal = strVal & vbLf & ws.Cells(i + m, j).Value
                Next m
                ws.Cells(i, j).Value = strVal: strVal = ""
           Next j
           For m = 1 To k                    'place the cells for rows to be deleted in a Union range, to delete at the end, at once
                If rngDel Is Nothing Then
                     Set rngDel = ws.Range("A" & i + m)
                Else
                    Set rngDel = Union(rngDel, ws.Range("A" & i + m))
                End If
         Next m
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete    'delete the not necessary rows
    ws.UsedRange.EntireRow.AutoFit: ws.UsedRange.EntireColumn.AutoFit
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub