工作簿拆分工作簿

zy19880405

我想根据“延发明细”这个表的 承运公司来拆分工作簿   但是我想保留其他表  网上找的代码 拆分了之后 只有一个表  没有其他表。。求大神帮忙看下

lsc900707

没问题呀，另外的表可以复制过去。晚上有时间再处理。

zy19880405

lsc900707 发表于 2018-8-31 12:05
没问题呀，另外的表可以复制过去。晚上有时间再处理。

大神，比较着急。有空的话能抽空帮我弄一下么

cjc209

你是要拆分为单独的工作簿还是就拆在本工作簿内？

chxw68

1. Sub test()
   
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.     If ws.Name <> "延发明细" Then
    
11.       m = m + 1
    
12.       ReDim Preserve brr(1 To m)
    
13.       brr(m) = ws.Name
    
14.     End If
    
15.   Next
    
16.   With Worksheets("延发明细")
    
17.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.     arr = .Range("a1:a" & r)
    
19.     For i = 2 To UBound(arr)
    
20.       If Not d.exists(arr(i, 1)) Then
    
21.         Set d(arr(i, 1)) = .Range("a1:p1")
    
22.       End If
    
23.       Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 16))
    
24.     Next
    
25.   End With
    
26.   Application.SheetsInNewWorkbook = 1
    
27.   For Each aa In d.keys
    
28.     Set wb = Workbooks.Add
    
29.     With wb
    
30.       With .Worksheets(1)
    
31.         .Name = "延发明细"
    
32.         d(aa).Copy .Range("a1")
    
33.       End With
    
34.       ThisWorkbook.Worksheets(brr).Copy after:=.Worksheets(1)
    
35.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
36.       .Close False
    
37.     End With
    
38.   Next
    
39.   Application.ScreenUpdating = True
    
40.   MsgBox "数据拆分完毕！"
    
41. End Sub
    

复制代码

chxw68

详见附件。

cjc209

chxw68 发表于 2018-8-31 12:56

老师 为什么你们都喜欢写固定代码 应该变量由自己决定才好 便于大家使用啊 比如表名一变 表头一变 对于不懂的人 就完蛋了 如果要求拆为独立的工作簿 由完蛋了

zy19880405

chxw68 发表于 2018-8-31 12:57
详见附件。

大神，我误解了我老板的意思了。。他的意思是把所有表的都按 承运商来拆分一下 。然后生成新的工作簿。。。不单单是 延发的。。

lsc900707

zy19880405 发表于 2018-8-31 13:16
大神，我误解了我老板的意思了。。他的意思是把所有表的都按 承运商来拆分一下 。然后生成新的工作簿。。 ...

Sub 多表同步拆分()
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     Set d = CreateObject("Scripting.Dictionary")
     Set wb1 = ThisWorkbook
     For Each sht In Sheets
         arA = sht.[a1].CurrentRegion
         For i = 1 To UBound(arA, 2)
             If arA(1, i) = "承运公司" Then j = i: Exit For
         Next
         For i = 2 To UBound(arA)
             d(arA(i, j)) = ""
         Next
     Next
     k = d.keys: t = d.items
     For i = 0 To UBound(k)
         Application.SheetsInNewWorkbook = wb1.Sheets.Count
         Workbooks.Add
         Set wb = ActiveWorkbook
         With wb
             For x = 1 To wb1.Sheets.Count
                 arA = wb1.Sheets(x).[a1].CurrentRegion
                 m = 1
                 For j = 1 To UBound(arA, 2)
                     If arA(1, j) = "承运公司" Then jj = j: Exit For
                 Next
                 For j = 2 To UBound(arA)
                     If arA(j, jj) = k(i) Then
                         m = m + 1
                         wb1.Sheets(x).Cells(j, 1).Resize(1, UBound(arA, 2)).Copy .Sheets(x).Cells(m, 1)
                         wb1.Sheets(x).Cells(1, 1).Resize(1, UBound(arA, 2)).Copy .Sheets(x).[a1]
                     End If
                 Next
                 Sheets(x).Name = wb1.Sheets(x).Name
                 .Sheets(x).[a2].CurrentRegion.Borders.LineStyle = 1
                 For y = 1 To UBound(arA, 2)
                     .Sheets(x).Columns(y).ColumnWidth = wb1.Sheets(x).Columns(y).ColumnWidth
                 Next
             Next
         End With
         wb.SaveAs ThisWorkbook.Path & "\" & k(i)
         wb.Close
     Next
     MsgBox "OK"
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
End Sub

zy19880405

lsc900707 发表于 2018-8-31 13:30
Sub 多表同步拆分()
     Application.ScreenUpdating = False
     Application.DisplayAlerts = Fals ...

版主大大 拆分了22个之后 到这一步错误。。