EXCEL用VBA实现单元格的自动合并和拆分
- 1、下载文档前请自行甄别文档内容的完整性,平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益,请联系客服反馈,我们会尽快为您处理(人工客服工作时间:9:00-18:30)。
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
(最初的程序来自网上,但原来的有不少问题,这个是修改过经过测试的)