从众多 Excel 文件中提取到一个数据表或文件中

Question

我有 100 多个 .xlsx 文件。每个文件有两张纸。第一张表（通常称为 sts）通常有 15-2 万行，有一列称为“代码”。第二张表（通常称为 cps）有大约 85k 行，也有相同的 Code 列。

我需要将特定代码的所有行从工作表 sts 提取到表/工作表中，并将特定代码的所有行从工作表 cps 提取到第二个表/工作表中。我需要对所有文件执行此操作。

我尝试了两种方法

1) 使用 Excel VBA 打开每个文件，使用自动过滤器将所需的代码行复制到主工作簿中进行排序。使用以下代码从预定义的起始目录中获取文件并向下钻取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

End Sub

我对此进行了调整以尝试使用 AcLink，但我正在努力实现它。是否可以使用 aclink 而不是 acimport 来查询每个文件进入 Access 时所需的代码行，如果是这样，这可能是一种更快的方法吗？

Answer 1

考虑在附加 SQL 查询中直接查询工作簿的第三种方法：

With rs
   .MoveLast
   .MoveFirst

   While (Not .EOF)                
      importfile = rs.Fields("Path")
      Debug.Print importfile

      sql = "INSERT INTO sts " _
          & " SELECT * FROM [Excel 12.0 Xml;HDR = Yes;Database=" & importfile & "].[Sts$A:G]"

       CurrentDb.Execute sql, dbFailOnError

      .MoveNext
   Wend        

   .Close    
End With

Answer 2

看起来你的第二个选项中的一个问题是我倾向于从 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