[已解决]求一个工作簿双表拆分VBA模块

icenotcool

各位老师好，我想各位老师帮我写一个一个工作簿双表按列拆分合并的模块，示例和拆分模拟效果在上传附件里，谢谢老师了 实例.rar (122.32 KB, 下载次数: 22)

2016-3-22 22:25 上传

点击文件名下载附件
，拆分出来的每个工作簿的表，里面可否设置自动一页打印区域且横向设置。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-3-23 09:15

1. Sub 拆分()
   
2.     Dim bt1 As Range, bt2 As Range, rng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     With Sheet1
   
7.         Set bt1 = .[a1:ad1]
   
8.         arr = .[a1].CurrentRegion
   
9.         For i = 2 To 10      'UBound(arr)
   
10.             Set rng = .Cells(i, 1).Resize(1, 30)
    
11.             x = arr(i, 3)
    
12.             d(x) = ""
    
13.             If Not d1.exists(x) Then Set d1(x) = Union(bt1, rng) Else Set d1(x) = Union(d1(x), rng)
    
14.         Next
    
15.     End With
    
16.    
    
17.     With Sheet2
    
18.         Set bt2 = .[a1:q2]
    
19.         arr = .[a1].CurrentRegion
    
20.         For i = 3 To 11        'UBound(arr)
    
21.             Set rng = .Cells(i, 1).Resize(1, 17)
    
22.             x = arr(i, 3)
    
23.             d(x) = ""
    
24.             If Not d2.exists(x) Then Set d2(x) = Union(bt2, rng) Else Set d2(x) = Union(d2(x), rng)
    
25.         Next
    
26.     End With
    
27.    
    
28.     For Each x In d.keys
    
29.         k = 0
    
30.         Workbooks.Add
    
31.         With ActiveWorkbook
    
32.             If d1.exists(x) Then
    
33.                 k = k + 1
    
34.                 d1(x).Copy .Sheets(k).[a1]
    
35.                 .Sheets(k).Name = "月薪"
    
36.             End If
    
37.             If d2.exists(x) Then
    
38.                 k = k + 1
    
39.                 d2(x).Copy .Sheets(k).[a1]
    
40.                 .Sheets(k).Name = "补贴"
    
41.             End If
    
42.             .SaveAs ThisWorkbook.Path & "" & x & ".xls"
    
43.             .Close
    
44.         End With
    
45.     Next
    
46. End Sub

复制代码

跳转到最佳答案楼层

爱疯

http://www.excelpx.com/thread-386168-1-1.html

可试试这个

icenotcool

爱疯 发表于 2016-3-22 22:55
http://www.excelpx.com/thread-386168-1-1.html

可试试这个

爱疯老师，我的不是单表拆，是双表拆，而且相同的要拆分放在同一个工作簿的

爱疯

icenotcool 发表于 2016-3-22 22:59
爱疯老师，我的不是单表拆，是双表拆，而且相同的要拆分放在同一个工作簿的

1）什么是单表拆，什么是双表拆?

2）相同的要拆分放在同一个工作簿的，不懂这句话是什么意思

icenotcool

爱疯 发表于 2016-3-22 23:06
1）什么是单表拆，什么是双表拆?

2）相同的要拆分放在同一个工作簿的，不懂这句话是什么意思

就是点击那个按钮同时对两个表拆分，都是按C列来拆，相同部门名字的拆分的表放在同一个以该部门名称为工作簿名称里面，你可以看看我附件里面的示例效果的

grf1973

1. Sub 拆分()
   
2.     Dim bt1 As Range, bt2 As Range, rng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     With Sheet1
   
7.         Set bt1 = .[a1:ad1]
   
8.         arr = .[a1].CurrentRegion
   
9.         For i = 2 To 10      'UBound(arr)
   
10.             Set rng = .Cells(i, 1).Resize(1, 30)
    
11.             x = arr(i, 3)
    
12.             d(x) = ""
    
13.             If Not d1.exists(x) Then Set d1(x) = Union(bt1, rng) Else Set d1(x) = Union(d1(x), rng)
    
14.         Next
    
15.     End With
    
16.    
    
17.     With Sheet2
    
18.         Set bt2 = .[a1:q2]
    
19.         arr = .[a1].CurrentRegion
    
20.         For i = 3 To 11        'UBound(arr)
    
21.             Set rng = .Cells(i, 1).Resize(1, 17)
    
22.             x = arr(i, 3)
    
23.             d(x) = ""
    
24.             If Not d2.exists(x) Then Set d2(x) = Union(bt2, rng) Else Set d2(x) = Union(d2(x), rng)
    
25.         Next
    
26.     End With
    
27.    
    
28.     For Each x In d.keys
    
29.         k = 0
    
30.         Workbooks.Add
    
31.         With ActiveWorkbook
    
32.             If d1.exists(x) Then
    
33.                 k = k + 1
    
34.                 d1(x).Copy .Sheets(k).[a1]
    
35.                 .Sheets(k).Name = "月薪"
    
36.             End If
    
37.             If d2.exists(x) Then
    
38.                 k = k + 1
    
39.                 d2(x).Copy .Sheets(k).[a1]
    
40.                 .Sheets(k).Name = "补贴"
    
41.             End If
    
42.             .SaveAs ThisWorkbook.Path & "" & x & ".xls"
    
43.             .Close
    
44.         End With
    
45.     Next
    
46. End Sub

复制代码

grf1973

测试中没放开全部数据，你自己把第9和第20句改为  for i=  .... to ubound(arr)即可。

icenotcool

grf1973 发表于 2016-3-23 09:17
测试中没放开全部数据，你自己把第9和第20句改为  for i=  .... to ubound(arr)即可。

老师，效果达到了，就是想补充一下，拆分出来的每个工作簿的表sheet可以设置成“拆自动一页打印区域且横向设置”吗？麻烦老师了

爱疯

Function getFolderPath() As String
    Dim Objshell As Object, Objfolder As Object
    Set Objshell = CreateObject("Shell.Application")
    Set Objfolder = Objshell.BrowseForFolder(0, "", 0, 0)
    getFolderPath = IIf(Objfolder Is Nothing, "", Objfolder.self.path)
    Set Objfolder = Nothing: Set Objshell = Nothing
End Function

Sub test()
    Dim p1, p2, p3, f, wb1, wb2
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p1 = getFolderPath
    p2 = getFolderPath
    p3 = ThisWorkbook.path

    f = Dir(p1 & "\*.*")
    Do While f <> ""
        Set wb1 = Workbooks.Open(p1 & "\" & f)
        wb1.SaveAs p3 & "\new" & wb1.Name    '避免打开时，wb1和wb2同名
        Set wb2 = Workbooks.Open(p2 & "\" & f)
        wb2.Sheets(1).Range("a1").CurrentRegion.Copy wb1.Sheets(2).Range("a1")
        wb1.Sheets(1).Name = "月薪"
        wb1.Sheets(2).Name = "补贴"
        wb1.Close True: Set wb1 = Nothing
        wb2.Close False: Set wb2 = Nothing
        f = Dir
    Loop
    MsgBox "ok"
End Sub
操作.rar (85.37 KB, 下载次数: 7)

2016-3-23 10:15 上传

点击文件名下载附件



使用步骤：
第1步：用2楼工具拆分本楼附件
            第1次拆分表1，得到文件夹比如20160323095006
            第2次拆分表2，得到文件夹比如20160323094712
第2步：运行本楼附件中的按钮

爱疯

楼上专门给你写了，那就用楼上的吧