如何将不同工作簿中的数据按照固定模板进行拆分合并

Macy1018

请教各位大神，现在有两个相关联的原始工作簿，以及拆分合并后最终呈现结果的固定模板，希望将原始工作簿中的数据按照企业编码进行拆分，每个企业生成一个以企业编码命名的独立工作簿，里面包含两个表单，数据分别来源于之前的两个原始工作簿，说起来有点乱，具体数据请看附件，跪求解决方法{:soso_e183:}

Macy1018

{:soso_e101:}没有人回复，求各位大神帮忙

蓝桥玄霜

1. Sub lqxs()
   
2. Dim myPath$, myName$
   
3. Dim Arr1, i&, wb As Workbook, n&, j&, aa, Brr(1 To 25, 1 To 1)
   
4. Dim d, k, t, d1, k1, Arr2, Arr3
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayAlerts = False
   
7. Set wb = ThisWorkbook
   
8. Set d = CreateObject("Scripting.Dictionary")
   
9. Set d1 = CreateObject("Scripting.Dictionary")
   
10. myPath = ThisWorkbook.Path & ""
    
11. myName = "企业人工成本情况（示例）.xlsx"
    
12. With GetObject(myPath & myName)
    
13.     Arr1 = .Sheets(1).Range("A1").CurrentRegion
    
14.     For i = 2 To UBound(Arr1)
    
15.         d1(Arr1(i, 1)) = i
    
16.     Next
    
17.     .Close False
    
18. End With
    
19. myName = "企业在岗职工工资调查（示例）.xlsx"
    
20. With GetObject(myPath & myName)
    
21.     Arr2 = .Sheets(1).Range("A1").CurrentRegion
    
22.     Arr3 = .Sheets(1).Range("k1").Resize(UBound(Arr2), 16)
    
23.     For i = 2 To UBound(Arr2)
    
24.         d(Arr2(i, 1) & "") = d(Arr2(i, 1) & "") & i & ","
    
25.     Next
    
26.     .Close False
    
27. End With
    
28. k = d.keys: t = d.items
    
29. For i = 0 To UBound(k)
    
30.     If d1.exists(k(i)) Then
    
31.         n = d1(k(i))
    
32.         For j = 2 To 11
    
33.             Brr(j - 1, 1) = Arr1(n, j)
    
34.         Next
    
35.         For j = 12 To 15
    
36.             Brr(j, 1) = Arr1(n, j)
    
37.         Next
    
38.         For j = 16 To UBound(Arr1, 2)
    
39.             Brr(j + 1, 1) = Arr1(n, j)
    
40.         Next
    
41.         Sheet1.[b2].Resize(25, 1) = Brr: Erase Brr
    
42.     End If
    
43.     t(i) = Left(t(i), Len(t(i)) - 1)
    
44.     If InStr(t(i), ",") Then
    
45.         aa = Split(t(i), ",")
    
46.         For j = 0 To UBound(aa)
    
47.             Sheet2.Cells(j + 4, 1).Resize(1, UBound(Arr3, 2)) = Application.Index(Arr3, aa(j), 0)
    
48.             Sheet2.Cells(j + 4, 17) = Arr2(aa(j), UBound(Arr2, 2))
    
49.         Next
    
50.     Else
    
51.         Sheet2.Cells(4, 1).Resize(1, UBound(Arr3, 2)) = Application.Index(Arr3, t(i), 0)
    
52.         Sheet2.Cells(4, 17) = Arr2(t(i), UBound(Arr2, 2))
    
53.     End If
    
54.     With ActiveWorkbook
    
55.         .SaveAs myPath & k(i) & ".xls"
    
56.     End With
    
57. Next
    
58. MsgBox "OK"
    
59. Application.DisplayAlerts = True
    
60. Application.ScreenUpdating = True
    
61. End Sub
    

复制代码

蓝桥玄霜

请见附件。
点击Ctrl+l  (小写L)  执行代码。

Macy1018

蓝桥玄霜 发表于 2015-11-7 13:01
请见附件。
点击Ctrl+l  (小写L)  执行代码。

完美地解决了我的问题，实在是太感谢您了，以后要多向您学习，为版主点赞！

Macy1018

蓝桥玄霜 发表于 2015-11-7 13:01
请见附件。
点击Ctrl+l  (小写L)  执行代码。

老师，当我放大量数据进去运行的时候（企业1000家，职工10几万人），程序出现了错误，提示“类型不匹配”，点击调试后，VBA第47行标黄，我个人能力有限，研究不出问题所在，还请老师再帮忙看看

funsz

Macy1018 发表于 2015-11-12 10:59
老师，当我放大量数据进去运行的时候（企业1000家，职工10几万人），程序出现了错误，提示“类型不匹配” ...

建议提供那条数据的附件，没有具体内容，也不好解决的