Excel·VBA单元格合并、撤销合并

1，合并选中单元格区域，并保留所有内容

Sub 合并选中单元格区域并保留所有数据()
    '合并选中单元格，单个单元格、单行、单列、多行多列都适用，可指定分隔符
    Dim rng As Range, result As String
    delimiter = "，"      '分隔符
    For Each rng In Selection  '从上到下、从左到右顺序
       result = result & delimiter & rng.Value
    Next rng
    result = Right(result, Len(result) - Len(delimiter))  '返回结果，同时去除开头的分隔符
    With Selection
        .Value = Empty   '内容清空
        .Merge  '合并单元格
        .Value = result  '内容赋值
        .WrapText = True  '是否自动换行
    End With
End Sub

举例

A、B列选中运行代码后得到D、E列效果

2，合并选中单元格区域，仅合并连续相同的值

Sub 合并选中单元格区域的连续同值()
    '合并选中单元格，适用单行、单列、多行多列区域
    Dim rng As Range, dict As Object, i, key_i, v
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    Set dict = CreateObject("scripting.dictionary")
    
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    For Each i In rng
        key_i = CStr(i.Value)
        If Not dict.Exists(key_i) Then
            Set dict(key_i) = i
        Else
            Set dict(key_i) = Application.Union(dict(key_i), i)
        End If
    Next
    v = dict.Items
    For i = 0 To dict.count - 1
        v(i).Merge
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

3，撤销选中区域内的合并单元格，并对单元格赋值原值

Sub 撤销选中区域的合并单元格()
    '撤销选中合并单元格，所有单元格赋值，单行、单列、多行多列都适用
    Dim rng As Range, i&, j&, first_row&, last_row&, first_col&, last_col&
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    first_row = rng.Row     '选中区域开始行号
    last_row = first_row + rng.Rows.count - 1  '选中区域结束行号
    first_col = rng.Column  '选中区域开始列号
    last_col = first_col + rng.Columns.count - 1  '选中区域结束列号
    
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    For i = first_row To last_row
        For j = first_col To last_col
            If Cells(i, j).MergeCells Then  '区域内是否包含合并单元格
                With Range(Cells(i, j).MergeArea.Address)  '合并单元格地址
                    .UnMerge  '撤销合并
                    .Value = Cells(i, j).Value  '全部赋值
                End With
            End If
        Next
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

举例

A列选中运行sub2后得到C列效果；相反C列选中运行sub3后得到A列效果

4，选中列向下合并连续空单元格

Sub 选中列向下合并连续空单元格()
    Dim rng As Range, i&, first_row&, last_row&, first_col&, s_row&, e_row&
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    If rng.Columns.Count > 1 Then Debug.Print "仅支持单列": Exit Sub  '仅支持单列，多列则退出
    first_row = rng.row     '选中区域开始行号
    last_row = first_row + rng.Rows.Count - 1  '选中区域结束行号
    first_col = rng.column  '选中区域开始列号
    
    s_row = first_row: e_row = first_row  '行号起止初始化
    For i = first_row To last_row
        If Cells(i, first_col).Value = "" Then
            e_row = i
        Else
            If s_row <> e_row Then Cells(s_row, first_col).Resize(e_row - s_row + 1, 1).Merge  '非空合并
            s_row = i: e_row = i
        End If
        If s_row <> e_row Then Cells(s_row, first_col).Resize(e_row - s_row + 1, 1).Merge  '最后一个合并
    Next
End Sub

举例

A列选中运行代码得到E列效果