从多个excel中提取相同命名的sheet中固定位置的数据

baiqitun23

各位大神，我是excel小白。
目前提取数据遇到麻烦，向各位请教。
在一个文件夹中，有大量excel文件，每个excel中有N个sheet，sheet都有命名，但这些sheet的先后顺序在不同excel中不同。比如，命名“三年二班”的sheet在excel1文件中位置在Sheet 1，而相同命名的sheet在excel2文件中位置在sheet5。
现在提取sheet名叫”三年二班“C20，D20，E20三个固定位置的数据。代码应该是怎样的呢？
求助各位，非常感谢！

feiren228

上传附件。。

opiona

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona() '//函数实例
   
8. Set SH0 = Sheet1
   
9. IROW = 1
   
10. FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)
    
11. For I = 0 To UBound(FileArr)
    
12.     Set WB = Workbooks.Open(FileArr(I))   '//打开工作簿
    
13.     Set SHNEW = WB.Worksheets("三年二班")
    
14.         SH0.Cells(IROW, 1) = SHNEW.Range("C20").Value
    
15.         SH0.Cells(IROW, 2) = SHNEW.Range("D20").Value
    
16.         SH0.Cells(IROW, 3) = SHNEW.Range("E20").Value
    
17.     WB.Close False  '//保存
    
18.     IROW = IROW + 1
    
19. Next
    
20. 
    
21. End Sub
    
22. '*******************************************************************************************************
    
23. '功能：    查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
    
24. '函数名：  FileAllArr
    
25. '参数1：   Filename    需查找的文件夹名 不含最后的""
    
26. '参数2：   FileFilter     需要过滤的文件名，可省略，默认为：[*.*]
    
27. '参数3：   Liwai           剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
    
28. '参数4：   Files           是否只要文件夹名，可省略，默认为：FALSE
    
29. '返回值：  一个字符型的数组
    
30. '使用方法：FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false)
    
31. '作者:    北极狐工作室 QQ：14885553
    
32. '*******************************************************************************************************
    
33. Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal Files As Boolean = False) As String()
    
34.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
35.     Set Did = CreateObject("Scripting.Dictionary")
    
36.     Dic.Add (Filename & ""), ""
    
37.     I = 0
    
38.     Do While I < Dic.Count
    
39.         Ke = Dic.keys   '开始遍历字典
    
40.         MyName = Dir(Ke(I), vbDirectory)    '查找目录
    
41.         Do While MyName <> ""
    
42.             If MyName <> "." And MyName <> ".." Then
    
43.                 If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
44.                     Dic.Add (Ke(I) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
45.                 End If
    
46.             End If
    
47.             MyName = Dir    '继续遍历寻找
    
48.         Loop
    
49.         I = I + 1
    
50.     Loop
    
51.     Dim arrx() As String
    
52.     I = 0
    
53.     If Files = True Then   '//是否只输出文件夹名
    
54.       
    
55.         For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
    
56.             ReDim Preserve arrx(I)
    
57.             If Ke <> Filename & "" Then  '//自身文件夹除外
    
58.                 arrx(I) = Ke
    
59.                 I = I + 1
    
60.             End If
    
61.          Next
    
62.          FileAllArr = arrx
    
63.     Else
    
64.         For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
    
65.             MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
    
66.             Do While MyFileName <> ""
    
67.                If MyFileName <> Liwai Then '排除例外文件
    
68.                   ReDim Preserve arrx(I)
    
69.                   arrx(I) = Ke & MyFileName
    
70.                   I = I + 1
    
71.                End If
    
72.                 MyFileName = Dir
    
73.             Loop
    
74.         Next
    
75.         FileAllArr = arrx
    
76.     End If
    
77. End Function
    
78. '****************************************************************
    
79. 
    
80. 
    
81. 
    

复制代码

baiqitun23

Excel文件.rar (21.35 KB, 下载次数: 33)

2015-5-11 17:28 上传

点击文件名下载附件
Excel文件

如附件所示，提取N个excel文件中命名“三年二班”的sheet中的C20，D20，E20的数据。多谢。

baiqitun23

feiren228 发表于 2015-5-11 17:18
上传附件。。

Excel文件.rar (21.35 KB, 下载次数: 31)

2015-5-11 17:30 上传

点击文件名下载附件
Excel文件

如附件所示，提取N个excel文件中命名“三年二班”的sheet中的C20，D20，E20的数据。多谢。

feiren228

baiqitun23 发表于 2015-5-11 17:30
如附件所示，提取N个excel文件中命名“三年二班”的sheet中的C20，D20，E20的数据。多谢。

起码做个汇总表的格式吧

baiqitun23

feiren228 发表于 2015-5-11 17:33
起码做个汇总表的格式吧

汇总表.rar (6.49 KB, 下载次数: 52)

2015-5-12 08:42 上传

点击文件名下载附件
汇总表

如附件，汇总表 A列 是excel文件名，B、C、D列分别是要提取的数据。

魂断蓝桥

baiqitun23 发表于 2015-5-12 08:44
如附件，汇总表 A列 是excel文件名，B、C、D列分别是要提取的数据。

汇总表，与分表放在同一目录下

Sub hb()
Dim arr, brr(1 To 999, 1 To 4), mypath, myfile As String, i As Integer, m As Integer
Dim cnn, rs, sql As String
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xlsx")
  Do While myfile <> ""
        If myfile <> ThisWorkbook.Name Then
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & mypath & myfile
            sql = "select * from [三年二班$c20:e20]"
            Set rs = cnn.Execute(sql)
            arr = rs.getRows
                    m = m + 1
                    brr(m, 1) = Replace(myfile, ".xlsx", "")
                    brr(m, 2) = arr(0, 0)
                    brr(m, 3) = arr(1, 0)
                    brr(m, 4) = arr(2, 0)
        End If
                myfile = Dir
        Loop
cnn.Close
Set cnn = Nothing
Set rs = Nothing
Sheet1.Activate
[a:d] = ""
[a1].Resize(m, 4) = brr
End Sub

中青鸟

魂断蓝桥 发表于 2015-5-12 09:10
汇总表，与分表放在同一目录下

Sub hb()

又看到大侠的文章!呵呵,学习一下

中青鸟

如果大侠们的代码能加点解释语句,对小白来说就最好了