「源代碼」VBA按任意列拆分工作簿

後臺有很多小夥伴們留言問怎麼實現按任意列拆分工作簿,其實這用VBA來實現很簡單,也很拿手。


大家先看效果:

「源代碼」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函數來讓使用者輸入需要拆分的列。Inputbox的用法,看截圖便可清晰的看到。


「源代碼」VBA按任意列拆分工作簿




分享到:


相關文章: