|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim wb As Workbook
- Dim ws As Worksheet
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- With Worksheets("密码")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:b" & r)
- For i = 1 To UBound(arr)
- d1(arr(i, 1)) = CStr(arr(i, 2))
- Next
- End With
- For Each ws In Worksheets(Array("A表", "B表", "C表"))
- With ws
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(1, .Columns.Count).End(xlToLeft).Column
- arr = .Range("b1:b" & r)
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 1)) Then
- Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
- End If
- If Not d(arr(i, 1)).exists(ws.Name) Then
- Set d(arr(i, 1))(ws.Name) = .Range("a1").Resize(1, c)
- End If
- Set d(arr(i, 1))(ws.Name) = Union(d(arr(i, 1))(ws.Name), .Cells(i, 1).Resize(1, c))
- Next
- End With
- Next
- For Each aa In d.keys
- Application.SheetsInNewWorkbook = d(aa).Count
- Set wb = Workbooks.Add
- p = 0
- With wb
- For Each bb In d(aa).keys
- p = p + 1
- With .Worksheets(p)
- .Name = bb
- d(aa)(bb).Copy .Range("a1")
- End With
- Next
- If d1.exists(aa) Then
- .SaveAs Filename:=ThisWorkbook.Path & "" & aa, Password:=d1(aa)
- Else
- .SaveAs Filename:=ThisWorkbook.Path & "" & aa
- End If
- .Close False
- End With
- Next
- Application.ScreenUpdating = True
- MsgBox "数据拆分完毕!"
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|