工作簿拆分工作簿

ykqrs

1. Sub qq()
   
2. Dim r%, i%, rng As Range, mf, arr, brr, c0%, c%, m%, t, x%
   
3. Dim d, aa, bb, ws As Worksheet, wb As Workbook
   
4. t = Timer
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. x = Application.SheetsInNewWorkbook
   
9. For Each ws In Worksheets
   
10. With ws
    
11. Set rng = Nothing
    
12. Set rng = .Rows(1).Find("承运公司", , , 1)
    
13. If Not rng Is Nothing Then
    
14. c0 = rng.Column
    
15. brr = .UsedRange
    
16. r = UBound(brr)
    
17. c = UBound(brr, 2)
    
18. arr = .Cells(1, c0).Resize(r, 1)
    
19. For i = 2 To UBound(arr)
    
20. If arr(i, 1) <> "" Then
    
21. If Not d.exists(arr(i, 1)) Then
    
22. Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
23. End If
    
24. If Not d(arr(i, 1)).exists(ws.Name) Then
    
25. Set d(arr(i, 1))(ws.Name) = .Range("a1").Resize(r, c)
    
26. End If
    
27. Set d(arr(i, 1))(ws.Name) = Union(d(arr(i, 1))(ws.Name), .Cells(i, 1).Resize(1, c))
    
28. End If
    
29. Next
    
30. End If
    
31. End With
    
32. Next
    
33. For Each aa In d.keys
    
34. mf = ThisWorkbook.Path & "" & aa
    
35. If Dir(mf, vbDirectory) = "" Then
    
36. MkDir mf
    
37. End If
    
38. Application.SheetsInNewWorkbook = d(aa).Count
    
39. Set wb = Workbooks.Add
    
40. m = 0
    
41. With wb
    
42. For Each bb In d(aa).keys
    
43. m = m + 1
    
44. With .Worksheets(m)
    
45. .Name = bb
    
46. d(aa)(bb).Copy .Range("a1")
    
47. .DrawingObjects.Delete
    
48. End With
    
49. Next
    
50. .SaveAs Filename:=mf & "" & Replace(aa, "/", "-") & ".xlsx"
    
51. .Close False
    
52. End With
    
53. Next
    
54. MsgBox Timer - t
    
55. Application.SheetsInNewWorkbook = x
    
56. End Sub
    

复制代码

chxw68

1. Sub test3()
   
2.   Dim r%, i%
   
3.   Dim arr, brr()
   
4.   Dim d As Object
   
5.   Dim ws As Worksheet
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   For Each ws In Worksheets
   
10.     With ws
    
11.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.       c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
13.       If r > 1 Then
    
14.         arr = .Range("a1:a" & r)
    
15.         For j = 1 To UBound(arr, 2)
    
16.           If arr(1, j) = "承运公司" Then
    
17.             Exit For
    
18.           End If
    
19.         Next
    
20.         If j <= UBound(arr, 2) Then
    
21.           For i = 2 To UBound(arr)
    
22.             If Not d.exists(arr(i, j)) Then
    
23.               Set d(arr(i, j)) = CreateObject("scripting.dictionary")
    
24.             End If
    
25.             If Not d(arr(i, j)).exists(ws.Name) Then
    
26.               Set d(arr(i, j))(ws.Name) = .Range("a1").Resize(1, c)
    
27.             End If
    
28.             Set d(arr(i, j))(ws.Name) = Union(d(arr(i, j))(ws.Name), .Cells(i, 1).Resize(1, c))
    
29.           Next
    
30.         End If
    
31.       End If
    
32.     End With
    
33.   Next
    
34.   For Each aa In d.keys
    
35.     Application.SheetsInNewWorkbook = d(aa).Count
    
36.     Set wb = Workbooks.Add
    
37.     m = 0
    
38.     With wb
    
39.       For Each bb In d(aa).keys
    
40.         m = m + 1
    
41.         With .Worksheets(m)
    
42.           .Name = bb
    
43.           d(aa)(bb).Copy .Range("a1")
    
44.         End With
    
45.       Next
    
46.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
47.       .Close False
    
48.     End With
    
49.   Next
    
50.   Application.ScreenUpdating = True
    
51.   MsgBox "数据拆分完毕！"
    
52. End Sub
    
53. 
    

复制代码

ykqrs

等待审核。。。。。。。。。。。。。。

chxw68

详见附件。

ykqrs

Sub qq()
Dim r%, i%, rng As Range, mf, arr, brr, c0%, c%, m%, t, x%
Dim d, aa, bb, ws As Worksheet, wb As Workbook
t = Timer
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
x = Application.SheetsInNewWorkbook
For Each ws In Worksheets
With ws
Set rng = Nothing
Set rng = .Rows(1).Find("承运公司", , , 1)
If Not rng Is Nothing Then
c0 = rng.Column
brr = .UsedRange
r = UBound(brr)
c = UBound(brr, 2)
arr = .Cells(1, c0).Resize(r, 1)
For i = 2 To UBound(arr)
If arr(i, 1) <> "" Then
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(r, c)
End If
Set d(arr(i, 1))(ws.Name) = Union(d(arr(i, 1))(ws.Name), .Cells(i, 1).Resize(1, c))
End If
Next
End If
End With
Next
For Each aa In d.keys
mf = ThisWorkbook.Path & "\" & aa
If Dir(mf, vbDirectory) = "" Then
MkDir mf
End If
Application.SheetsInNewWorkbook = d(aa).Count
Set wb = Workbooks.Add
m = 0
With wb
For Each bb In d(aa).keys
m = m + 1
With .Worksheets(m)
.Name = bb
d(aa)(bb).Copy .Range("a1")
.DrawingObjects.Delete
End With
Next
.SaveAs Filename:=mf & "\" & Replace(aa, "/", "-") & ".xlsx"
.Close False
End With
Next
MsgBox Timer - t
Application.SheetsInNewWorkbook = x
End Sub

lsc900707

zy19880405 发表于 2018-8-31 14:00
版主大大 拆分了22个之后 到这一步错误。。

你的数据里有一条带斜杠的，属于非法字符，检查一下看看。

zy19880405

lsc900707 发表于 2018-8-31 14:52
你的数据里有一条带斜杠的，属于非法字符，检查一下看看。

斜杠？？？日期那里的？？

lsc900707

zy19880405 发表于 2018-8-31 14:59
斜杠？？？日期那里的？？

“质损明细”中

报险起数        出险时间        运输车号        承运公司
1        2018/7/3        沪EB2485        安顺
2        2018/7/5        京AEB702       京顺达/世纪物流
3        2018/7/17        京AEX157        大通
4        2018/7/31        辽J21189        厚德

zy19880405

chxw68 发表于 2018-8-31 14:47
详见附件。

您这个会漏。。。

chxw68

zy19880405 发表于 2018-8-31 15:24
您这个会漏。。。

漏了什么？