将多个工作簿组合成一个工作表

Question

我当前正在尝试将数据记录到Excel工作簿中，以将其自动复制到一个"质量数据"表中。这些文件由日期ex命名。" 5-28-17"。一个月的每一天都有一个。如前所述，我想将所有数据收集到一张纸上，按日期下降。我目前正在使用此代码，该代码应该将所有不同的工作簿放在他们自己的工作表上，但是我也有问题。

 Option Explicit
Const path As String = "C:UsersdtDesktopdt 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

我将使用此addin。

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:PathToExcelDatabase.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:UsersdtDesktopdt kte"
    Const accpath As String = "C:PathToExcelDatabase.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