拆分工作簿增强

VBA工作表事件实现

“聚光灯效果”

昨天分享的拆分工作簿代码得到了大家的认可和赞同。后台也有小伙伴留言问怎么实现按其他任意列拆分工作簿。

其实这很简单，只需要稍微修改其他变量即可。

大家先看效果：

实现代码：

Sub 拆分2()

Application.ScreenUpdating = False'关闭屏幕闪动，提速

Application.DisplayAlerts = False'关闭窗口提示

kk = 2

Set dic = CreateObject("scripting.dictionary")

With ThisWorkbook.Worksheets("汇总表")

cln = InputBox("请输入需要按列拆分的列:" & Chr(10) & "英文列标", "输入列标", "A")'inputbox提示输入需要拆分的列标

cln2 = .Range("a1").End(xlToRight).Column'获取最大列数，为了增加通用性

Set rng1 = .Range(.Cells(1, 1), .Cells(1, cln2))

If .Range(cln & 2) = "" Then Exit Sub

rrow = .Cells(Rows.Count, cln).End(xlUp).Row

arr = WorksheetFunction.Transpose(.Range(cln & 1 & ":" & cln & rrow))

For i = 2 To UBound(arr)'将A列已有数据写入字典，为了去重复。也可以用高级筛选

If Not dic.exists(arr(i)) Then'若字典中不存在该字符串，则写入。

dic.Add arr(i), .Range("a" & i).Resize(1, cln2)

Else

Set dic.Item(arr(i)) = Union(dic.Item(arr(i)), .Range("a" & i).Resize(1, cln2))

End If

Next

k = dic.keys

l = dic.items

For ss = 0 To dic.Count - 1

Set wb = Workbooks.Add'新建工作簿

With wb.Worksheets(1)

rng1.Copy .Range("a1")'把表头的前一行也一同复制到新工作表中

l(ss).Copy .Range("a2")

End With

wb.SaveAs ThisWorkbook.Path & "\" & k(ss) & ".xlsx"'将新建的工作簿保存在代码工作簿下

wb.Close True'关闭工作簿，并保存

Set wb = Nothing'释放内存

Next

End With

Application.ScreenUpdating = True

Application.DisplayAlerts = True

MsgBox "完成"

End Sub

其实，和上一节的代码相比，就多了个inputbox函数。他的用法，一看截图便可清晰的看到。

若需要同时拆分多个工作簿，需在修改代码，自己摸索。

附件链接：https://pan.baidu.com/s/1dDxG7O 密码：bynx

不懂的地方均可以在下方留言给我。

只分享干货。