從眾多 Excel 文件中提取到一個數據表或文件中

Question

我有 100 多個 .xlsx 文件。 每個文件有兩張紙。 第一張表（始終稱為 sts）通常有 15-2 萬行，其中有一列稱為“代碼”。 第二張表（始終稱為 cps）有大約 85k 行，也有相同的代碼列。

我需要將特定代碼的所有行從工作表 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，但我正在努力實現它。 當它進入 Access 時，是否可以使用 aclink 而不是 acimport 來查詢每個文件所需的代碼行，如果是這樣，這可能是一種更快的方法嗎？

Answer 1

看起來您的第二個選項中的問題之一（我傾向於支持）是您要從 Excel 文件導入所有行。 嘗試使用 Excel 對象模型在兩個工作表上定義命名范圍，然后在循環中使用 docmd.transferspreadsheet。 您將需要更改其他工作表的列引用。 哈。

用於查找實際使用的行、定義命名范圍並導入 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 

Answer 2

考慮在追加 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