[已解决]批量拆分（汇总的逆序）

ccgqc

要求：1.将总表D至H列的数据分别复制粘贴到各分表里去（注意原表还有数据，不能是生成表）；
2.不在同一目录下，按工程名称要对应；工程名称里的《数据表》名称是固定；

批量操作，一键搞定

最佳答案

月排行榜 / 总排行榜

dsmch

2014-5-18 21:13

………………

跳转到最佳答案楼层

ccgqc

这个看起来简单，实际上很难

ccgqc

要求：1.将总表D至H列的数据分别复制粘贴到各分表里去（注意原表还有数据，不能是生成表）；
2.不在同一目录下，按工程名称要对应；工程名称里的，数据表文件夹，《数据表》名称是固定，夹与表名称不一定相同；

ccgqc

没人回复，我自己顶

dsmch

1. Dim d
   
2. Sub Ipbox()
   
3. On Error Resume Next
   
4. Dim arr, brr, crr, d2, i&, j%, h&
   
5. Set d = CreateObject("scripting.dictionary") '文件路径
   
6. Set d2 = CreateObject("scripting.dictionary") '行、列
   
7. arr = [a3:h7]
   
8. For i = 2 To UBound(arr)
   
9.     d2(arr(i, 2)) = i
   
10. Next
    
11. For j = 4 To UBound(arr, 2)
    
12.     d2(arr(1, j)) = j
    
13. Next
    
14. Zdir ThisWorkbook.Path & "\工程文件" '递归查找文件夹及子文件夹下文件
    
15. Application.ScreenUpdating = False
    
16. Application.DisplayAlerts = False
    
17. For i = 2 To UBound(arr)
    
18.     h = d2(arr(i, 2))
    
19.     Workbooks.Open (d(arr(i, 2)))
    
20.     brr = Sheets(1).Range("a1").CurrentRegion
    
21.     ReDim crr(1 To UBound(brr) - 1, 1 To 1)
    
22.     For j = 2 To UBound(brr)
    
23.         crr(j - 1, 1) = arr(h, d2(brr(j, 1)))
    
24.     Next
    
25.     Sheets(1).Range("b2").Resize(UBound(crr)) = crr
    
26.     Workbooks("数据表.xls").Close 1
    
27. Next
    
28. Application.DisplayAlerts = True
    
29. Application.ScreenUpdating = True
    
30. End Sub
    
31. Sub Zdir(P)
    
32. Set Fso = CreateObject("scripting.filesystemobject")
    
33. For Each f In Fso.GetFolder(P).Files
    
34.     x = Split(f, "")
    
35.     d(x(UBound(x) - 1)) = f
    
36. Next
    
37. For Each m In Fso.GetFolder(P).SubFolders
    
38.     Zdir m
    
39. Next
    
40. End Sub
    

复制代码

dsmch

………………

ccgqc

总是很强大

ccgqc

谢谢！

ccgqc

大侠，我的数据表有两张，第一张不是按规律的，大概是这样，你帮我看看，谢谢

ccgqc

dsmch 发表于 2014-5-18 21:13
………………

大侠，我的数据表有两张，第一张不是按规律的，大概是这样，你帮我看看，谢谢