[已解决]急求文件夹下的3000个Excel文件中某几个单元格的数据写入到汇总.xls文件宏代码

hgqing2010

急求文件夹下的3000个Excel文件中某几个单元格的数据写入到汇总.xls文件宏代码

最佳答案

月排行榜 / 总排行榜

美斯特邦威

2013-11-4 17:47

hgqing2010 发表于 2013-11-4 16:40
感谢美斯特邦威! 烦劳再对代码作个注解，特别是循环结构里的代码。

1. Sub abc()
   
2.     Application.ScreenUpdating = False '关闭屏幕刷新
   
3.         Set d = CreateObject("scripting.dictionary") '创建字典
   
4.         st = Dir(ThisWorkbook.Path & "" & "*.xls") '定义变量为当前工作薄的xls文件，下面循环
   
5.         m = 1
   
6.         pp = Range("a1:bs2").Value '将此单元格区域存为数值pp，初值
   
7.             Do While st <> "" '循环st，直到st为空值，也就是所有xls文件循环
   
8.                 qq = pp '设置qq为循环中的初值变量，每个文件开始循环都设置qq为初值pp
   
9.                 If st <> "汇总.xls" Then '汇总的本工作薄不需循环
   
10.                     Set wb = GetObject(ThisWorkbook.Path & "" & st) '设置wb为当前循环到的xls文件
    
11.                         With wb.Sheets(1)
    
12.                             kk = .Range("b5:h72").Value '因区域固定，所以wb的每个工作表固定区域存为数值
    
13.                                 For i = 1 To UBound(kk) '对kk进行循环
    
14.                                 For j = 3 To 7 Step 4 'kk的列进行循环，这里只取表中的基础数据列
    
15.                                     If kk(i, j - 2) <> "" Then '空值略过
    
16.                                     d(Replace(kk(i, j - 2), "★", "")) = kk(i, j) '将每个项目名称和对应的基础数据存入字典，项目名称去掉★
    
17.                                     End If
    
18.                                     Next j, i
    
19.                                     For j = 1 To UBound(qq, 2)
    
20.                                     qq(2, j) = d(qq(1, j))  '在qq数组中循环，第二行的数据通过第一行对应用以上存入的字典获取
    
21.                                 Next j
    
22.                             Cells(m + 1, 1).Resize(1, UBound(qq, 2)) = Application.Index(qq, 2) '将新得到的数组qq的第二行读取到对应的位置
    
23.                             m = m + 1 '位置+1，也就是一行一个表的数据
    
24.                             d.RemoveAll '清空数组，以便下次循环
    
25.                         End With
    
26.                     wb.Close False '不保存关闭已用过的xls文件
    
27.                 End If
    
28.                 st = Dir() '下一个xls文件循环
    
29.             Loop
    
30.     Application.ScreenUpdating = True '打开屏幕刷新
    
31. End Sub

复制代码

跳转到最佳答案楼层

CheryBTL

可以实现呀，最后能上个附件，并模拟下结果。

ppp710715

可以做到，上附件来！

hgqing2010

RE: 急求文件夹下的3000个Excel文件中某几个单元格的数据写入到汇总.xls文件宏代码


附件

hgqing2010

感谢各位的关注，刚才上传了附件，急。。。。。

美斯特邦威

hgqing2010 发表于 2013-11-4 14:58
感谢各位的关注，刚才上传了附件，急。。。。。

1. Sub abc()
   
2.     Application.ScreenUpdating = False
   
3.         Set d = CreateObject("scripting.dictionary")
   
4.         st = Dir(ThisWorkbook.Path & "" & "*.xls")
   
5.         m = 1
   
6.         pp = Range("a1:bs2").Value
   
7.             Do While st <> ""
   
8.                 qq = pp
   
9.                 If st <> "汇总.xls" Then
   
10.                     Set wb = GetObject(ThisWorkbook.Path & "" & st)
    
11.                         With wb.Sheets(1)
    
12.                             kk = .Range("b5:h72").Value
    
13.                                 For i = 1 To UBound(kk)
    
14.                                 For j = 3 To 7 Step 4
    
15.                                     If kk(i, j - 2) <> "" Then
    
16.                                     d(Replace(kk(i, j - 2), "★", "")) = kk(i, j)
    
17.                                     End If
    
18.                                     Next j, i
    
19.                                     For j = 1 To UBound(qq, 2)
    
20.                                     qq(2, j) = d(qq(1, j))
    
21.                                 Next j
    
22.                             Cells(m + 1, 1).Resize(1, UBound(qq, 2)) = Application.Index(qq, 2)
    
23.                             m = m + 1
    
24.                             d.RemoveAll
    
25.                         End With
    
26.                     wb.Close False
    
27.                 End If
    
28.                 st = Dir()
    
29.             Loop
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

看看是不是你需要的

hgqing2010

感谢美斯特邦威! 烦劳再对代码作个注解，特别是循环结构里的代码。

美斯特邦威

hgqing2010 发表于 2013-11-4 16:40
感谢美斯特邦威! 烦劳再对代码作个注解，特别是循环结构里的代码。

1. Sub abc()
   
2.     Application.ScreenUpdating = False '关闭屏幕刷新
   
3.         Set d = CreateObject("scripting.dictionary") '创建字典
   
4.         st = Dir(ThisWorkbook.Path & "" & "*.xls") '定义变量为当前工作薄的xls文件，下面循环
   
5.         m = 1
   
6.         pp = Range("a1:bs2").Value '将此单元格区域存为数值pp，初值
   
7.             Do While st <> "" '循环st，直到st为空值，也就是所有xls文件循环
   
8.                 qq = pp '设置qq为循环中的初值变量，每个文件开始循环都设置qq为初值pp
   
9.                 If st <> "汇总.xls" Then '汇总的本工作薄不需循环
   
10.                     Set wb = GetObject(ThisWorkbook.Path & "" & st) '设置wb为当前循环到的xls文件
    
11.                         With wb.Sheets(1)
    
12.                             kk = .Range("b5:h72").Value '因区域固定，所以wb的每个工作表固定区域存为数值
    
13.                                 For i = 1 To UBound(kk) '对kk进行循环
    
14.                                 For j = 3 To 7 Step 4 'kk的列进行循环，这里只取表中的基础数据列
    
15.                                     If kk(i, j - 2) <> "" Then '空值略过
    
16.                                     d(Replace(kk(i, j - 2), "★", "")) = kk(i, j) '将每个项目名称和对应的基础数据存入字典，项目名称去掉★
    
17.                                     End If
    
18.                                     Next j, i
    
19.                                     For j = 1 To UBound(qq, 2)
    
20.                                     qq(2, j) = d(qq(1, j))  '在qq数组中循环，第二行的数据通过第一行对应用以上存入的字典获取
    
21.                                 Next j
    
22.                             Cells(m + 1, 1).Resize(1, UBound(qq, 2)) = Application.Index(qq, 2) '将新得到的数组qq的第二行读取到对应的位置
    
23.                             m = m + 1 '位置+1，也就是一行一个表的数据
    
24.                             d.RemoveAll '清空数组，以便下次循环
    
25.                         End With
    
26.                     wb.Close False '不保存关闭已用过的xls文件
    
27.                 End If
    
28.                 st = Dir() '下一个xls文件循环
    
29.             Loop
    
30.     Application.ScreenUpdating = True '打开屏幕刷新
    
31. End Sub

复制代码