从众多的Excel文件中提取数据到一个数据表或文件的方法
我有超过100个.xlsx文件。 这些文件中的每一个都有两张纸。 在第一张纸上（总是叫sts）通常有大约15-20万行，并有一列叫做“代码”。 第二张（总是称为cps）有大约85k行，也有相同的代码栏。
我需要从表单sts中提取所有行的特定代码，将表格/表单中的所有行以及表单cps中特定代码的所有行转换为第二个表格/表单，并且我需要为所有100个单数文件。 我尝试了两种方法
1）使用Excel VBA打开每个文件，使用自动filter将需要的代码行复制到主工作簿中进行整理。 使用以下代码从预定义的起始目录中获取文件并向下钻取Public Sub SearchFiles（）
Public Sub SearchFiles() 'Macro to start the file extraction by drilling down from the mydir path specified Dim code As String Dim time1 As Double Dim time2 As Double Range("a1").Value = InputBox("Please type code to extract", code) time1 = Timer myFileSearch _ myDir:="C:\Data\Dashboard\2014\New Files Excel Loop", _ FileNameLike:="Reporting", _ FileTypeLike:=".xlsx", _ SearchSubFol:=True, _ myCounter:=0 time2 = Timer MsgBox time2 - time1 & "seconds" End Sub Private Sub myFileSearch(myDir As String, FileNameLike As String, FileTypeLike As String, _ SearchSubFol As Boolean, myCounter As Long) Dim fso As Object, myFolder As Object, myFile As Object Dim Rowcount As Long Dim rowcount2 As Long Dim masterbook As Workbook Set masterbook = ThisWorkbook Set fso = CreateObject("Scripting.FileSystemObject") Dim commodity As String code = Range("a1").Value Application.ScreenUpdating = False For Each myFile In fso.GetFolder(myDir).Files Workbooks.Open (myDir & "\" & myFile.Name) myCounter = myCounter + 1 ReDim Preserve myList(1 To myCounter) myList(myCounter) = myDir & "\" & myFile.Name ''loop to pull out all code rows in your directories into new file Workbooks(Workbooks.Count).Worksheets(1).Range("d2").Activate Rowcount = Workbooks(1).Sheets(1).Range("a1").CurrentRegion.Rows.Count + 1 Rows(1).AutoFilter Range("A1").AutoFilter Field:=3, Criteria1:=code, Operator:=xlAnd Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _ Destination:=Workbooks(1).Sheets(1).Range("a" & Rowcount) 'filter out the code data Workbooks(Workbooks.Count).Worksheets(2).Activate Range("d2").Activate rowcount2 = Workbooks(1).Sheets(2).Range("a1").CurrentRegion.Rows.Count + 1 Rows(1).AutoFilter Range("A1").AutoFilter Field:=6, Criteria1:=code, Operator:=xlAnd Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _ Destination:=Workbooks(1).Sheets(2).Range("a" & Rowcount) Workbooks(myFile.Name).Close savechanges:=False Next If SearchSubFol Then For Each myFolder In fso.GetFolder(myDir).SubFolders myFileSearch myDir & "\" & myFolder.Name, FileNameLike, FileTypeLike, True, myCounter Next End If End Sub 这种方法的问题是它不是很快。 打开每个工作簿需要5-10秒，整个过程非常缓慢（目前有错误）。
2）第二种方法是将所有内容吸收到两个Access表中。 我试图导入每个文件，然后清除只是我想要的代码行，但是这实际上比上面的Excel方法慢，因为行数。
Sub pulloop() DoCmd.RunSQL "delete * from sts" DoCmd.RunSQL "delete * from cps" strSql = "PathMap" Set rs = CurrentDb.OpenRecordset(strSql) With rs If Not .BOF And Not .EOF Then .MoveLast .MoveFirst While (Not .EOF) importfile = rs.Fields("Path") DoCmd.TransferSpreadsheet acimport, acSpreadsheetTypeExcel12, "Sts", importfile, True, "Sts!A:G" DoCmd.TransferSpreadsheet acimport, acSpreadsheetTypeExcel12, "CPs", importfile, True, "CPs!A:Q" 'Debug.Print rs.Fields("Path") .MoveNext Wend End If .Close End With
结束小组
我调整了这个，然后尝试使用AcLink，但我正在努力实现它。 是否有可能使用aclink而不是acimport查询每个文件在访问时所需的代码行，如果是的话，这可能是一个更快的方法？
对于这篇长文章的道歉，请随时提出任何build议。
它看起来像你的第二个选项，我倾向于赞成的问题之一是，你是从Excel文件导入所有的行。 尝试使用Excel对象模型在两张纸上定义一个命名范围，然后在循环中使用docmd.transferspreadsheet。 您将需要更改另一张纸的列参考。 HTH。
代码来查找使用的实际行，定义一个命名范围并导入到Access中：
Dim xlApp As Excel.Application Dim xlWkb As Excel.Workbook Dim xlWS As Excel.Worksheet Dim lngLastRow as Long Dim myImportRange as Range dim strRangeName as String set xlApp = New Excel.Application xlApp.Visible=False 'make it go faster set xlWB = xlApp.Workbooks.Open("PATH") set xlWS = xlWB.Sheets("sts") lngLastRow=xlWS.Range("A" & xlWS.Rows.Count).End(xlUp).Row Set myImportRange = xlWS.Range("A1:G" & lnglastrow) strRangeName="myData_2014MMDD" 'or any name that makes sense to you myImportRange.Name=strRangeName xlWB.Save DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, <Dest Table>, xlWb.FullName, True, strRangeName xlApp.DisplayAlerts=False 'suppress save changes prompts xlWB.Close False