VBA带有多个子表的工作簿拆分?

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim wb As Workbook
   
6.   Dim mypath$, myname$
   
7.   Dim d As Object
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   Set d1 = CreateObject("scripting.dictionary")
    
12.   For Each ws In Worksheets
    
13.     With ws
    
14.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.       c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
16.       arr = .Range("a1").Resize(r, c)
    
17.       For j = 1 To UBound(arr, 2)
    
18.         If arr(2, j) = "所属销售" Then
    
19.           Exit For
    
20.         End If
    
21.       Next
    
22.       Set d1(ws.Name) = .Range("a1").Resize(2, c)
    
23.       If j <= UBound(arr, 2) Then
    
24.         For i = 3 To UBound(arr)
    
25.           If Not d.exists(arr(i, j)) Then
    
26.             Set d(arr(i, j)) = CreateObject("scripting.dictionary")
    
27.           End If
    
28.           If Not d(arr(i, j)).exists(ws.Name) Then
    
29.             Set d(arr(i, j))(ws.Name) = .Cells(i, 1).Resize(1, c)
    
30.           Else
    
31.             Set d(arr(i, j))(ws.Name) = Union(d(arr(i, j))(ws.Name), .Cells(i, 1).Resize(1, c))
    
32.           End If
    
33.         Next
    
34.       End If
    
35.     End With
    
36.   Next
    
37.   Application.SheetsInNewWorkbook = d1.Count
    
38.   For Each aa In d.keys
    
39.     Set wb = Workbooks.Add
    
40.     m = 0
    
41.     With wb
    
42.       For Each bb In d1.keys
    
43.         m = m + 1
    
44.         With .Worksheets(m)
    
45.           .Name = bb
    
46.           d1(bb).Copy .Range("a1")
    
47.           If d(aa).exists(bb) Then
    
48.             d(aa)(bb).Copy .Range("a3")
    
49.             c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
50.           Else
    
51. '            .Cells(3, 3) = CDate("2018-" & Replace(ws.Name, ".", "-"))
    
52. '            .cells(3,4).resize(
    
53.           End If
    
54.           r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    
55.           .Cells(r, 6) = "当日合计："
    
56.           .Cells(r, 7) = "=SUM(R3C:R[-1]C)"
    
57.         End With
    
58.       Next
    
59.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
60.       .Close False
    
61.     End With
    
62.   Next
    
63.   Application.ScreenUpdating = True
    
64.   MsgBox "数据拆分完毕！"
    
65. End Sub
    

复制代码

雨下大了

chxw68 发表于 2018-8-30 20:53

十分感谢您！好厉害！！！