将多个工作簿合并为一个工作表

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