如何从多个excel文件中提取固定单元格数据

jiaoting

各位大神求助，如何在文件夹下的files子文件夹中提取多个excel文件的固定单元格，需要判定文件名，比如文件名中带有总监的字样的，需要自动调取该文件中总监的表，标有经理的需要自动调取该文件中经理的表。表格提取数据有，名字，综合分数这两个，都是固定位置
因为文件比较多，能否用运行比较快的方案？不用每个文件打开的那种

需要抓取的数据是，k1跟e3单元格

jiaoting

之前看过这个代码，挺好的，就是不知怎么修改

Sub ADO法()
    Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, m&, arr()
    Set Fso = CreateObject("Scripting.FileSystemObject")
    ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count, 1 To 2)
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xlsx" Then
            m = m + 1
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & File
            Set rs = cnn.Execute("[Sheet1$a2:a2]")
            arr(m, 1) = rs.Fields(0)
            Set rs = cnn.Execute("[Sheet1$g41:g41]")
            arr(m, 2) = rs.Fields(0)
        End If
    Next
    ActiveSheet.UsedRange.Offset(1).ClearContents
    If m > 0 Then [a2].Resize(m, 2) = arr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
End Sub

925750100

留脚印，以备用

yqg2136

这是我之前写过的代码，对照修改一下就可以用
Sub 数据归集()
   Dim myPath$, myFile$, i
   Application.ScreenUpdating = False
   myPath = ThisWorkbook.Path & "\"
   myFile = Dir(myPath & "*.xls*")
      ThisWorkbook.Sheets("数据归集").UsedRange.Offset(2).ClearContents '你需要汇总的工作簿中的工作表，offset(2)为第三行开始，从几行开始就写其-1
      i = 3
                                          
            Do While myFile <> ""
             If myFile <> ThisWorkbook.Name Then
                 With Workbooks.Open(myPath & myFile)
                   .Worksheets("利润表").Range("D5").Copy
                    ThisWorkbook.Sheets("数据归集").Cells(i, 2).PasteSpecial xlPasteValues '你需要汇总的工作簿中的工作表对应单元格复制提取的对象工作表对应单元格的数值，仅数值不复制格式和公式，下同
                     .Worksheets("利润表").Range("D6").Copy
                    ThisWorkbook.Sheets("数据归集").Cells(i, 3).PasteSpecial xlPasteValues
                     Application.CutCopyMode = False
                    .Close False
                    i = i + 1
                End With
            End If
            myFile = Dir
        Loop
      
   Application.ScreenUpdating = True
   MsgBox "搞定，洗洗睡吧，亲！", 64, "提示"
End Sub

jiaoting

yqg2136 发表于 2019-6-30 21:31
这是我之前写过的代码，对照修改一下就可以用
Sub 数据归集()
   Dim myPath$, myFile$, i

谢谢，这个用的是文件操作，文件少的时候还可以，多了效率太低了，我已经研究解决了，代码在下面

jiaoting

1. Sub 提取总分()
   
2.     Dim Fso As Object, oFolder As Object, oFile As Object, cnn As Object, rs As Object, m&, arr$()
   
3.     Dim sFilePath As String, Sql1 As String, Sql2 As String, Sql3 As String
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     sFilePath = ThisWorkbook.Path & "\Files"
   
6.     Set oFolder = Fso.GetFolder(sFilePath)          '获取Files所在文件夹
   
7.     ReDim arr$(1 To oFolder.Files.Count, 1 To 4)    '初始化arr数组
   
8.     Application.ScreenUpdating = False              '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
   
9.     Worksheets("数据缓存表").UsedRange.ClearContents    '情况sheet2内容
   
10.    
    
11.     For Each oFile In oFolder.Files
    
12.         If oFile.Name Like "*经理*.xls*" Then
    
13.             Sql1 = "SELECT * FROM [月度-工程经理（土建）$b3:b3]"    '项目名称
    
14.             Sql2 = "SELECT * FROM [月度-工程经理（土建）$e3:e3]"    '姓名
    
15.             Sql3 = "SELECT * FROM [月度-工程经理（土建）$k1:k1]"    '分数
    
16.             Call oSql(cnn, rs, oFile, Sql1, Sql2, Sql3, arr(), m)
    
17.         ElseIf oFile.Name Like "*总监*.xls*" Then
    
18.             Sql1 = "SELECT * FROM [月度-工程总监$b3:b3]"    '项目名称
    
19.             Sql2 = "SELECT * FROM [月度-工程总监$e3:e3]"    '姓名
    
20.             Sql3 = "SELECT * FROM [月度-工程总监$k1:k1]"    '分数
    
21.             Call oSql(cnn, rs, oFile, Sql1, Sql2, Sql3, arr(), m)
    
22.         ElseIf oFile.Name Like "*平台*.xls*" Then
    
23.             Sql1 = "SELECT '平台' FROM [平台$]"     '姓名
    
24.             Sql2 = "SELECT * FROM [平台$c3:c3]"     '姓名
    
25.             Sql3 = "SELECT * FROM [平台$b1:b1]"     '分数
    
26.             Call oSql(cnn, rs, oFile, Sql1, Sql2, Sql3, arr(), m)
    
27.         End If
    
28.         Next
    
29.         
    
30.     If m > 0 Then Sheets("数据缓存表").[a1].Resize(m, 4) = arr
    
31.     rs.Close
    
32.     cnn.Close
    
33.     Set rs = Nothing
    
34.     Set cnn = Nothing
    
35.     Set oFile = Nothing
    
36.     Set oFolder = Nothing
    
37.     Set Fso = Nothing
    
38.     Worksheets("数据缓存表").Range("c:c") = Worksheets("数据缓存表").Range("c:c").Value   '数据缓存表C列转换为数字格式
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    
41. Sub oSql(cnn, rs, ByVal oFile As Object, Sql1, Sql2, Sql3, arr$(), m&)
    
42.         m = m + 1
    
43.         Set cnn = CreateObject("ADODB.Connection")
    
44.         cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & oFile.Path
    
45.         On Error Resume Next
    
46.         Set rs = cnn.Execute(Sql1)
    
47.         arr(m, 1) = rs.Fields(0)
    
48.         Set rs = cnn.Execute(Sql2)
    
49.         arr(m, 2) = rs.Fields(0)
    
50.         Set rs = cnn.Execute(Sql3)
    
51.         arr(m, 3) = rs.Fields(0)
    
52.         arr(m, 4) = oFile.Name
    
53. End Sub
    

复制代码

这个代码可以任意扩展多列，多文件，我是用了块状结构化，可以稍微修改即可，使用的是ADO方法，直接把文件夹中的excel表文件当成数据库进行连接，使用cnn.execute+范围进行控制，可以提取单个单元格，或者提取单元格区域

yqg2136

jiaoting 发表于 2019-7-1 15:28
这个代码可以任意扩展多列，多文件，我是用了块状结构化，可以稍微修改即可，使用的是ADO方法，直接 ...

这个好，学习了

tayezuifeng

jiaoting 发表于 2019-7-1 15:28
这个代码可以任意扩展多列，多文件，我是用了块状结构化，可以稍微修改即可，使用的是ADO方法，直接 ...

Sub 提取总分()
    Dim Fso As Object, oFolder As Object, oFile As Object, cnn As Object, rs As Object, m&, arr$()
    Dim sFilePath As String, Sql1 As String, Sql2 As String, Sql3 As String, Sql4 As String
    Set Fso = CreateObject("Scripting.FileSystemObject")
    sFilePath = ThisWorkbook.Path & "\Files"
    Set oFolder = Fso.GetFolder(sFilePath)          '获取Files所在文件夹
    ReDim arr$(1 To oFolder.Files.Count, 1 To 5)    '初始化arr数组
    Application.ScreenUpdating = False              '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
    Worksheets("数据缓存表").UsedRange.ClearContents    '情况sheet2内容
   
    For Each oFile In oFolder.Files
        If oFile.Name Like "*.xls*" Then
            Sql1 = "SELECT * FROM [GNC$c3:c3]"    '姓名
            Sql2 = "SELECT * FROM [GNC$c4:c4]"    '性别
            Sql3 = "SELECT * FROM [GNC$c13:c13]"    '短期去过否
            Sql4 = "SELECT * FROM [GNC$e12:e12]"    '短期期数
            Call oSql(cnn, rs, oFile, Sql1, Sql2, Sql3, Sq14, arr(), m)
        End If
        Next
        
    If m > 0 Then Sheets("数据缓存表").[a1].Resize(m, 5) = arr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
    Set Fso = Nothing
    Worksheets("数据缓存表").Range("c:c") = Worksheets("数据缓存表").Range("c:c").Value   '数据缓存表C列转换为数字格式
    Application.ScreenUpdating = True
End Sub
Sub oSql(cnn, rs, ByVal oFile As Object, Sql1, Sql2, Sql3, Sq14, arr$(), m&)
        m = m + 1
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & oFile.Path
        On Error Resume Next
        Set rs = cnn.Execute(Sql1)
        arr(m, 1) = rs.Fields(0)
        Set rs = cnn.Execute(Sql2)
        arr(m, 2) = rs.Fields(0)
        Set rs = cnn.Execute(Sql3)
        arr(m, 3) = rs.Fields(0)
        Set rs = cnn.Execute(Sql4)
        arr(m, 4) = rs.Fields(0)
        arr(m, 5) = oFile.Name
End Sub

您好，我增加一维的，Sql4为什么没有数值呢？请指教？

jeckey_an

学习了。

淡定工藤

留脚印，以备用