将多个工作簿合并到一个工作表中

Question

我目前正在尝试将记录到 Excel 工作簿中的数据自动复制到一张“海量数据”表中。这些文件按日期命名。 “5-28-17”。每个月的每一天都有一个。如前所述，我想按日期降序将所有数据收集到一张表中。 我目前正在使用这段代码，它应该将所有不同的工作簿放在他们自己的工作表上，但我也遇到了问题。

 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 列。都排得很完美。有没有办法将工作表从我目前正在处理的 WB 中移动，该工作表应该包含每个 WB 的工作表到一个批量工作表上？或者我可以直接从文件夹中提取所有数据，所有工作簿按日期保存到一个工作表中？

Answer 1

我会使用这个插件。

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

它会做你想做的事，还有更多。

Answer 2

考虑使用 MS Access 数据库。如果您没有安装 Office GUI .exe 应用程序，请不要担心。因为您使用的是 Windows 机器，所以您确实有它的 Jet/ACE SQL 引擎（.dll 文件）。

创建数据库

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