|
本帖最后由 ykcbf1100 于 2024-4-10 21:29 编辑
参与一下。。。
- Sub ykcbf() '//2024.4.10
- Dim arr, d
- Set fso = CreateObject("Scripting.FileSystemObject")
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Dim tm: tm = Timer
- Set d = CreateObject("Scripting.Dictionary")
- Set sh = ThisWorkbook.Sheets("Sheet1")
- p = ThisWorkbook.Path & ""
- With Sheets("Sheet1")
- r = .Cells(.Rows.Count, "a").End(xlUp).Row
- arr = .[a1].Resize(r, 5)
- End With
- For i = 2 To UBound(arr)
- s = arr(i, 2): ss = CStr(arr(i, 1))
- If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
- If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
- d(s)(ss)(i) = i
- Next
- For Each k In d.keys
- p1 = p & k & ""
- If Not fso.FolderExists(p1) Then fso.CreateFolder p1
- For Each kk In d(k).keys
- Application.SheetsInNewWorkbook = 1
- Set wb = Workbooks.Add
- m = 0
- ReDim brr(1 To UBound(arr), 1 To 3)
- With wb.Sheets(1)
- .Name = kk
- For Each kkk In d(k)(kk).keys
- m = m + 1
- For j = 3 To UBound(arr, 2)
- brr(m, j - 2) = arr(kkk, j)
- Next
- Next
- .[a1].Resize(m, 3) = brr
- End With
- wb.SaveAs p1 & kk,6
- wb.Close
- Next
- Next
- Set d = Nothing
- Application.ScreenUpdating = True
- MsgBox "共用时:" & Format(Timer - tm) & "秒!"
- End Sub
复制代码
|
|