批量合并单元格VBA

nnsea

Sub MergeRange()   
    Dim rngData As Range
    Dim i&, lngCol&, lngFirst, lngLast
    On Error Resume Next
    Set rngData = Application.InputBox("请选择单列数据列！", Default:=Selection.Address, Type:=8)
    '用户选择数据列
    Set rngData = Intersect(rngData.Parent.UsedRange, rngData)
    'intersect语句避免用户选择整列造成低效运算
    lngCol = rngData.Column 'rngData所在列
    lngFirst = rngData.Row
    '用户选择的区域并不是一定从第一行开始，使用此句读取开始行
    lngLast = lngFirst + rngData.Rows.Count - 1
    'rngData结束行
    Application.ScreenUpdating = False
    '取消屏幕刷新
    Application.DisplayAlerts = False
    '取消消息提醒。
    rngData.Parent.Select
    '激活rngData对象所在的工作表，避免跨工作表操作问题
    For i = lngLast To lngFirst + 1 Step -1
    '对rngData进行从尾向前遍历
        If Cells(i, lngCol) = Cells(i - 1, lngCol) Then
            Cells(i - 1, lngCol).Resize(2, 1).Merge
        End If
    Next
    rngData.VerticalAlignment = xlCenter
    '单元格格式上下居中
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "合并完成。"
End Sub