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

合集下载
相关主题
  1. 1、下载文档前请自行甄别文档内容的完整性,平台不提供额外的编辑、内容补充、找答案等附加服务。
  2. 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
  3. 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

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

相关文档
最新文档