拆分工作簿增強

VBA工作表事件實現

「聚光燈效果」

昨天分享的拆分工作簿代碼得到了大家的認可和贊同。後台也有小夥伴留言問怎麼實現按其他任意列拆分工作簿。

其實這很簡單，只需要稍微修改其他變數即可。

大家先看效果：

GIF

實現代碼：

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

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

只分享乾貨。

喜歡這篇文章嗎？立刻分享出去讓更多人知道吧！