多工作簿并表问题

丢丢表格

说明：（历遍工作簿的问题）

       是这样一个工作表表签同是【SHEET1】，同时发给各经办人员（20~30）人左右（即有20~30个工作簿，每个工作簿表只有此一表）,  经办人员在 ”情况说明“中录入要素后，回传时，与原表顺序将会不同（汇总表数据在300行之内），数据行只会少，而不会增加。但格式是一致的。

        各经办人回传的的工作表表名无定名。

       所有回传的工作簿都放在     C:\Users\abc\Desktop\问题汇总  文件夹里

要求：

      把各经办人回传的工作簿中以B列企业为查找值（无重复），凡有F、G、H 列有 ”情况说明“ 都读入汇总表对应企业的情况说明列里。（只要F列不为空，就可以把这三列的内容同时拷入【问题汇总】表中）

    本人只会一点函数， 对 VBA 很生疏，有请老师帮助！！

ivccav

注意文件夹要按你说的位置。在我的电脑上试过了，没啥问题。

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     t = Timer
   
4.     r = Range("b" & Rows.Count).End(3).Row
   
5.     arr = Range("b2:h" & r)
   
6.     strFileName = Dir(" C:\Users\abc\Desktop\问题汇总\*.xls*")
   
7.     Do While Len(strFileName)
   
8.         If ThisWorkbook.Name <> strFileName Then
   
9.             strFileName = " C:\Users\abc\Desktop\问题汇总" & strFileName
   
10.             With Workbooks.Open(Filename:=strFileName, ReadOnly:=True)
    
11.                 .Windows(1).Visible = False
    
12.                 r = .Worksheets(1).Range("b" & Rows.Count).End(3).Row
    
13.                 brr = .Worksheets(1).Range("b2:h" & r)
    
14.                 .Windows(1).Visible = True
    
15.                 .Close False
    
16.             End With
    
17.             For i = 1 To UBound(arr)
    
18.                 For j = 1 To UBound(brr)
    
19.                     If brr(j, 1) = arr(i, 1) And Len(brr(j, 5)) > 0 Then
    
20.                         arr(i, 5) = brr(j, 5)
    
21.                         arr(i, 6) = brr(j, 6)
    
22.                         arr(i, 7) = brr(j, 7)
    
23.                     End If
    
24.                 Next
    
25.             Next
    
26.         End If
    
27.         strFileName = Dir
    
28.     Loop
    
29.     Range("b2:h" & r) = arr
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "汇总完毕，用时" & Format(Timer - t, "0.00秒")
    
32. End Sub
    

复制代码

问题汇总.zip (52.35 KB, 下载次数: 13)

2018-6-5 23:33 上传

点击文件名下载附件

丢丢表格

ivccav 发表于 2018-6-5 23:34
注意文件夹要按你说的位置。在我的电脑上试过了，没啥问题。

谢谢，我先测试一下。

丢丢表格

ivccav 发表于 2018-6-5 23:34
注意文件夹要按你说的位置。在我的电脑上试过了，没啥问题。

有1205行的表，共有 21个工作簿 ，计算速度是 4.25 秒，测试通过。
   感谢 ivccav  老师的大力帮助 。

ivccav

丢丢表格 发表于 2018-6-6 19:09
有1205行的表，共有 21个工作簿 ，计算速度是 4.25 秒，测试通过。
   感谢 ivccav  老师的大力帮助 。

如果每个人只填一行的话，可以在下面语句加一句Exit For，能减少一些循环。
如果有人需要填写多行的，不可加语句。

1. If brr(j, 1) = arr(i, 1) And Len(brr(j, 5)) > 0 Then
   
2.     arr(i, 5) = brr(j, 5)
   
3.     arr(i, 6) = brr(j, 6)
   
4.     arr(i, 7) = brr(j, 7)
   
5. <font color="#ff0000">    'Exit For'如果每人只填一行，可以在每个工作簿找到情况说明的非空列之后就退出，能减少循环</font>
   
6. End If
   

复制代码

也可以用字典，这样循环更少。不过你的数据行很少，看不到明显效果。时间都花在打开工作簿上了。
以下是用字典的方式，循环少一点，仅供参考。没发现速度有提升。

1. Sub test2()
   
2.     Application.ScreenUpdating = False
   
3.     t = Timer
   
4.     r = Range("b" & Rows.Count).End(3).Row
   
5.     arr = Range("b2:h" & r)
   
6.     strFileName = Dir("C:\Users\abc\Desktop\问题汇总\*.xls*")
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Do While Len(strFileName)
   
9.         If ThisWorkbook.Name <> strFileName Then
   
10.             strFileName = "C:\Users\abc\Desktop\问题汇总" & strFileName
    
11.             With Workbooks.Open(Filename:=strFileName, ReadOnly:=True)
    
12.                 .Windows(1).Visible = False
    
13.                 r = .Worksheets(1).Range("b" & Rows.Count).End(3).Row
    
14.                 brr = .Worksheets(1).Range("b2:h" & r)
    
15.                 .Windows(1).Visible = True
    
16.                 .Close False
    
17.             End With
    
18.             For j = 1 To UBound(brr)
    
19.                 If Len(brr(j, 5)) Then
    
20.                     d(brr(j, 1)) = brr(j, 5) & "@@" & brr(j, 6) & "@@" & brr(j, 7) '用特殊字符@@连接3列，方便后面拆分
    
21.                 End If
    
22.             Next
    
23.         End If
    
24.         strFileName = Dir
    
25.     Loop
    
26.     For j = 1 To UBound(arr)
    
27.         If d.exists(arr(j, 1)) Then
    
28.             brr = Split(d(arr(j, 1)), "@@")
    
29.             arr(j, 5) = brr(0)
    
30.             arr(j, 6) = brr(1)
    
31.             arr(j, 7) = brr(2)
    
32.         End If
    
33.     Next
    
34.     Range("b2:h" & r) = arr
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "汇总完毕，用时" & Format(Timer - t, "0.00秒")
    
37. End Sub

复制代码

问题汇总.zip (54.76 KB, 下载次数: 6)

2018-6-6 21:14 上传

点击文件名下载附件

丢丢表格

ivccav 发表于 2018-6-6 21:15
如果每个人只填一行的话，可以在下面语句加一句Exit For，能减少一些循环。
如果有人需要填写多行的 ...

因为 B 列是导入日期 （带时、分、秒 的唯一值），通过用数组后 再回写时，就自动 清除多余的空格 ，再次运行合并表时，原来的值就不相同了，造成无回写数据 。 （ Range("b2:h" & r) = arr ）
  我采用 分区域 来装数组 ：
   Arr = Range("B2:B" & r)
   App = Range("F2:H" & r)

   避开 B 列的值， 用 Range("F2:H" & r) = App 来回写， 成功

     多谢老师你的 大力帮助 ！！