[已解决]多工作簿汇总

grf1973

在原代码的基础上小改了一下。

1. Sub grf()
   
2.     Dim d As Object, arr, fl$, tp$, wk, Wb As Workbook, Sh As Worksheet, iRow&, a%, i&
   
3.     Set Sh = ActiveSheet
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sh.Range("a3:o" & Sh.[c65536].End(3).Row)
   
6.     For i = 2 To UBound(arr)     '已有项目进字典
   
7.         If arr(i, 3) = "" Then arr(i, 3) = arr(i - 1, 3)
   
8.         xm = arr(i, 3)
   
9.         If Len(xm) > 0 Then
   
10.             d(xm) = ""
    
11.             d(xm & arr(i, 4)) = arr(i, 14)       '项目+模板的完成情况
    
12.         End If
    
13.     Next
    
14.    
    
15.     tp = ThisWorkbook.Path & ""
    
16.     fl = Dir(tp & "*.xls*")
    
17.     Application.ScreenUpdating = False
    
18.     Application.DisplayAlerts = False
    
19. 
    
20.     Do While Len(fl)
    
21.         If fl <> ThisWorkbook.Name Then
    
22.             Set wk = Workbooks.Open(tp & fl)
    
23.             With wk.Sheets(1)
    
24.                 xm = .[b4]    '项目
    
25.                 If Not d.exists(xm) Then    '项目不存在，新增
    
26.                     iRow = Sh.[d65536].End(3).Row + 1
    
27.                     Sh.Cells(iRow, "b") = Application.WorksheetFunction.Max(Sh.Range("b:b")) + 1      '序号
    
28.                     Sh.Cells(iRow, "o") = Sh.Cells(iRow, "b")
    
29.                     Sh.Cells(iRow, "c") = xm
    
30.                     Sh.Cells(iRow, "d").Resize(7, 1) = .[a17].Resize(7, 1).Value
    
31.                     Sh.Cells(iRow, "e").Resize(7, 1) = .[F17].Resize(7, 1).Value
    
32.                     Sh.Cells(iRow, "f").Resize(7, 1) = .[g17].Resize(7, 1).Value
    
33.                     Sh.Cells(iRow, "g") = .[f4]
    
34.                     Sh.Cells(iRow, "h") = .[h4]
    
35.                     Sh.Cells(iRow, "i") = .[j6] & ":" & [k6]
    
36.                     Sh.Cells(iRow, "j") = .[c8]
    
37.                     Sh.Cells(iRow, "k") = .[b30]
    
38.                     Sh.Cells(iRow, "N") = .[m4]
    
39.                 Else        '项目存在，填充M列
    
40.                     For i = 17 To 24
    
41.                         x = xm & .Cells(i, 1)
    
42.                         If d.exists(x) Then Cells(i, "m") = d(x)
    
43.                     Next
    
44.                 End If
    
45.             End With
    
46.             wk.Close (True)
    
47.         End If
    
48.         fl = Dir
    
49.     Loop
    
50.     Application.DisplayAlerts = True
    
51.     Application.ScreenUpdating = True
    
52. End Sub

复制代码

wxfwxj

grf1973 发表于 2016-3-16 13:42
在原代码的基础上小改了一下。

前辈你好，非常感谢你的解答
1，由于汇总表的模板名称是由其他工作簿A列与E列合并的所以在复制N列是会出错，
2，想把汇总表的m列的内容也向n列一样可以复制到其他工作簿的N列

grf1973

请看附件。

wxfwxj

grf1973 发表于 2016-3-16 15:32
请看附件。

序号是否可以这样

grf1973

请看附件。

wxfwxj

grf1973 发表于 2016-3-16 16:49
请看附件。

非常感谢前辈！

wxfwxj

grf1973 发表于 2016-3-16 16:49
请看附件。

你好前辈，在实际应用时发现有同名的项目名称，所以不能用项目名称来判断是否已经加载过，在汇总表的P列增加订单编号，用订单编号来判断是否已经加载过！

grf1973

我早问你以什么判断唯一性

wxfwxj

grf1973 发表于 2016-3-16 21:43
我早问你以什么判断唯一性

求前辈再帮忙看看，谢谢！ 求助 (2).zip (36.92 KB, 下载次数: 4)

2016-3-17 09:17 上传

点击文件名下载附件

grf1973

以订单号为key，放在P列。不按你的附件那样插入列，插入的话要改动的代码太多。