如何将多个在不同文件夹的相同excel工作表的内容导入到一张格式完全不一样的工作表

dan1117

如何将多个在不同文件夹的相同excel工作表的内容导入到一张格式完全不一样的工作表当中

因为有上千份工作表，人工输入效率太低，而且时间也赶不及，希望各位大侠不吝赐教，小女子感激不尽~

总表图如下：
：


子表图如下：


文件夹示例图如下：

总表.rar (14.85 KB, 下载次数: 251)

2011-8-23 15:09 上传

点击文件名下载附件

子表.rar (134.24 KB, 下载次数: 280)

2011-8-23 15:09 上传

点击文件名下载附件

angus029

路过，不会

opiona

1. Sub OPIONA() '使用双字典，旨在提高速度
   
2.     Dim MyName, Dic, Did, I, T, F, TT, MyFileName
   
3. Application.ScreenUpdating = False '关闭屏幕刷新
   
4. Application.DisplayAlerts = False '关闭提示
   
5.     T = Timer
   
6.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
   
7.     Set Did = CreateObject("Scripting.Dictionary")
   
8.     Dic.Add (ThisWorkbook.Path & ""), ""
   
9.     I = 0
   
10.     Do While I < Dic.Count
    
11.         Ke = Dic.keys   '开始遍历字典
    
12.         MyName = Dir(Ke(I), vbDirectory)    '查找目录
    
13.         Do While MyName <> ""
    
14.             If MyName <> "." And MyName <> ".." Then
    
15.                 If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
16.                     Dic.Add (Ke(I) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
17.                 End If
    
18.             End If
    
19.             MyName = Dir    '继续遍历寻找
    
20.         Loop
    
21.         I = I + 1
    
22.     Loop
    
23.   
    
24.   a = 3 '总表数据开始行
    
25.   'a = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1 '如果总表是不断累加的，总表数据开始行
    
26.     For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
    
27.         MyFileName = Dir(Ke & "*.xls") 'EXCEL2003为：*.xlsx,excel2007为：*.xlsx
    
28.         Do While MyFileName <> ""
    
29.            If MyFileName <> ThisWorkbook.Name Then
    
30.               Set xlBook = Workbooks.Open(Ke & MyFileName) '打开已经存在的EXCEL工件簿文件
    
31.                   For Each sh In xlBook.Worksheets '遍历工作表
    
32.                       If sh.Cells(5, 2) = "省份" Then '工作表为所需表
    
33.                          ThisWorkbook.Sheets(1).Cells(a, 1) = sh.Cells(5, 3)
    
34.                          ThisWorkbook.Sheets(1).Cells(a, 2) = sh.Cells(6, 3)
    
35.                          ThisWorkbook.Sheets(1).Cells(a, 3) = sh.Cells(5, 9)
    
36.                          ThisWorkbook.Sheets(1).Cells(a, 4) = sh.Cells(6, 9)
    
37.                          '..............以此类推
    
38.                          a = a + 1  '记录指针指向下一行
    
39.                       End If
    
40.                   Next
    
41.               Windows(MyFileName).Close (False)   '关闭工作簿，不保存
    
42.            End If
    
43.             MyFileName = Dir
    
44.         Loop
    
45.     Next
    
46. Application.ScreenUpdating = True
    
47. Application.DisplayAlerts = True
    
48.     MsgBox "一共用时：" & Timer - T & "秒"
    
49. End Sub
    

复制代码

szqhb

貌似写得很详细，不知道符不符合楼主的要求啊！！！

紫伊93

我完全看不懂   能写得简单点吗？？？

xrs08234

俺用的是2003版，打不开附件，就一段时间没来，大家都用高版本的EXCEL了。想学习一下大家的，没办法了。

Lisa_168

路过  偶也不会 不好意思了

clchg

路过，，看看

wss0002

留个脚印，改天再来学习了

kszcs

看看高手的答案