VBA 选中区域合并或取消合并单元格

chunyu.wu

已于 2024-07-12 14:24:59 修改

阅读量690

点赞数 2

分类专栏： VBA 文章标签： VBA

于 2024-07-12 13:38:16 首次发布

本文链接：https://blog.csdn.net/wuchunyu002/article/details/140376873

版权

VBA 专栏收录该内容

67 篇文章

订阅专栏

1. 合并单元格

Sub MergeCells()
    Dim i, j As Long
    Dim cell As Range
    Dim intMinRow, intMaxRow As Long
    Dim intMinCol, intMaxCol As Long
    Dim strMergeValue As String
    Dim objMergeArea As Range
    Dim rng As Range
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)
    If rng Is Nothing Then Exit Sub
    
    intMinRow = rng.Cells(1, 1).Row
    intMaxRow = rng.Cells(rng.Cells.Count).Row
    intMinCol = rng.Cells(1, 1).Column
    intMaxCol = rng.Cells(rng.Cells.Count).Column
    
    Application.DisplayAlerts = False
    
    Set rng = Intersect(ActiveSheet.UsedRange, rng)
    
    For j = intMinCol To intMaxCol
        For i = intMaxRow To intMinRow Step -1
            Set cell = Cells(i, j)
            If cell.Value <> "" And cell.Offset(1, 0).Value = cell.Value Then
                cell.Resize(2, 1).Merge
            End If
        Next i
    Next j
    
    Application.DisplayAlerts = True
    'MsgBox "Done."
    MessageBoxTimeout 0, "Done.", "Merge Cells", 0, 1, 500
    
End Sub

2. 取消合并单元格

Sub UnmergeCells()
    Dim i, j As Long
    Dim cell As Range
    Dim intMinRow, intMaxRow As Long
    Dim intMinCol, intMaxCol As Long
    Dim strMergeValue As String
    Dim objMergeArea As Range
    Dim rng As Range
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)
    If rng Is Nothing Then Exit Sub
    
    intMinRow = rng.Cells(1, 1).Row
    intMaxRow = rng.Cells(rng.Cells.Count).Row
    intMinCol = rng.Cells(1, 1).Column
    intMaxCol = rng.Cells(rng.Cells.Count).Column
    
    For i = intMinRow To intMaxRow
        For j = intMinCol To intMaxCol
            Set cell = Cells(i, j)
            strMergeValue = cell.MergeArea.Cells(1, 1).Value
            Set objMergeArea = Range(cell.MergeArea.Address)
            objMergeArea.MergeCells = False
            For Each rng In objMergeArea
                rng.Value = strMergeValue
                'rng.VerticalAlignment = xlCenter
                'rng.HorizontalAlignment = xlLeft
            Next
        Next j
    Next i
    
    'MsgBox "Done."
    MessageBoxTimeout 0, "Done.", "Unmerge Cells", 0, 1, 500
    
End Sub