EXCEL用VBA实现单元格的自动合并和拆分

EXCEL用VBA实现单元格的自动合并和拆分

Stanley

Excel中分级显示功能不强。最常用的方法是把高层的单元格合并。但这样往往导致排序、筛选等“数据”功能不能使用，这时又要拆分；然后再合并。。。拆分。。。。

这里提供了我自己用的、用VBA实现的、单元格自动合并和拆分的程序。使用时请作为宏来执行。希望对大家有用。

Sub MergeActiveWorkbookActiveSheetVertically()

Dim m, n, t, col As Long

Application.DisplayAlerts = False

For col = 1 To 100 'set firest and last column that can be merged

m = 2 ' compare from row 2, row 1 must be title of the table!

For n = 3 To Cells(Rows.Count, col).End(3).Row + 1

If Cells(n, col).Value <> Cells(n - 1, col).Value And m < n Then 'find the first different value under current cell

With Range(Cells(m, col), Cells(n - 1, col))

.Merge

.HorizontalAlignment = xlLeft 'Center

.VerticalAlignment = xlCenter

End With

m = n

End If

If Cells(n, col).Value = "" Then

m = n + 1

End If

Next n

Next col

Application.DisplayAlerts = True

End Sub

Private Sub UnMergeActiveWorkbookActiveSheet()

Dim i As Range

Dim v As Variant

Dim k, j As Integer

For Each i In edRange 'must give the ActiveWorkbook!

If i.Address <> i.MergeArea.Address And i.Address = i.MergeArea.Item(1).Address Then v = i.Value

i.MergeArea.Select

i.MergeArea.UnMerge

For j = Selection.Row To Selection.Row + Selection.Rows.Count - 1 'fill the rect area!

For k = Selection.Column To Selection.Column + Selection.Columns.Count - 1

ActiveWorkbook.ActiveSheet.Cells(j, k) = v

Next k

Next j

End If

Next i

Cells(1, 1).Select

End Sub

（最初的程序来自网上，但原来的有不少问题，这个是修改过经过测试的）