將多個工作簿合併爲一個工作表

Question

我目前正在嘗試將記錄到Excel工作簿中的數據自動複製到一個「海量數據」工作表上。這些文件按日期前名稱命名。 「17年5月28日」。每個月的每一天都有一個。如前所述，我希望按日期順序將所有數據收集到一張表中。 我目前使用的代碼應該將所有不同的工作簿放到他們自己的工作表上，但我也遇到了問題。

Option Explicit 
Const path As String = "C:\Users\dt\Desktop\dt kte\" 
Sub GetSheets() 
Dim FileName As String 
Dim wb As Workbook 
Dim sheet As Worksheet 

FileName = Dir(path & "*.xls*") 
Do While FileName <> "" 
Set wb = Workbooks.Open(FileName:=path & FileName, ReadOnly:=True) 
For Each sheet In wb.Sheets 
    sheet.Copy After:=ThisWorkbook.Sheets(1) 
Next sheet 
wb.Close 
FileName = Dir() 
Loop 
End Sub 

我想用VBA做到這一點。我從中拉出的表格中有15列，而我要複製的表格中有15列。所有排隊完美。有沒有辦法將我目前正在處理的WB中的工作表從每個工作表上移到一個工作表上？或者我能否將所有數據直接從文件夾中按日期保存到一個工作表中？

Answer 1

我會用這個AddIn。

https://www.rondebruin.nl/win/addins/rdbmerge.htm

它會做你想要什麼，和很多的還有很多。

Answer 2

考慮使用MS Access數據庫。不用擔心，如果您沒有安裝Office GUI .exe應用程序。由於您使用的是Windows機器，因此您的Jet/ACE SQL Engine（.dll文件）。

CREATE DATABASE

Sub CreateDatabase() 
On Error GoTo ErrHandle 
    Dim fso As Object, olDb As Object, db As Object 
    Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0"  
    Const strpath As String = "C:\Path\To\ExcelDatabase.accdb" 

    ' CREATE DATABASE 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set olDb = CreateObject("DAO.DBEngine.120") 

    If Not fso.FileExists(strpath) Then 
     Set db = olDb.CreateDatabase(strpath, dbLangGeneral) 
    End If 

    MsgBox "Successfully created database!", vbInformation 

ExitSub: 
    Set db = Nothing: Set olDb = Nothing: Set fso = Nothing 
    Exit Sub 

ErrHandle: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR" 
    Resume ExitSub 
End Sub 

創建，填充，導出Excel表格（Excel文件從來沒有打開）

Sub CreateTable() 
On Error GoTo ErrHandle 
    Dim conn As Object, rst As Object 
    Dim constr As String, FileName As String, i As Integer 
    Const xlpath As String = "C:\Users\dt\Desktop\dt kte\" 
    Const accpath As String = "C:\Path\To\ExcelDatabase.accdb" 

    ' CONNECT TO DATABASE 
    constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accpath & ";" 
    Set conn = CreateObject("ADODB.Connection") 
    conn.Open constr 

    i = 1 
    FileName = Dir(xlpath & "*.xls*") 

    Do While FileName <> "" 
     If i = 1 Then 
      ' CREATE TABLE VIA MAKE TABLE QUERY 
      conn.Execute "SELECT * INTO MyExcelTable" _ 
          & " FROM [Excel 12.0 Xml;HDR=Yes;" _ 
          & " Database=" & xlpath & FileName & "].[Sheet1$]" 
     Else 
      ' POPULATE VIA APPEND QUERY 
      conn.Execute "INSERT INTO MyExcelTable" _ 
          & " SELECT * FROM [Excel 12.0 Xml;HDR=Yes;" _ 
          & " Database=" & xlpath & FileName & "].[Sheet1$]" 
     End If 

     i = i + 1 
     FileName = Dir() 
    Loop 

    ' EXPORT TO EXCEL 
    Set rst = CreateObject("ADODB.Recordset") 
    rst.Open "SELECT * FROM MyExcelTable", conn 

    ThisWorkbook.Worksheets("MASS_DATA").Range("A1").CopyFromRecordset rst 

    ' CLOSE CONNECTION 
    rst.Close: conn.Close 

    MsgBox "Successfully created and populated table!", vbInformation 

ExitSub: 
    Set rst = Nothing: Set conn = Nothing 
    Exit Sub 

ErrHandle: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR" 
    Resume ExitSub  
End Sub