Question

我目前正在尝试将记录到excel工作簿中的数据自动复制到一个＆＃34;海量数据＆＃34;片。文件按日期ex命名。＆＃34; 17年5月28日＆＃34 ;.每个月的每一天都有一个。我希望按照之前的说明将所有数据收集到一张纸上，按日期递减顺序排列。我目前正在使用这个代码，它应该将所有不同的工作簿放在他们自己的工作表上，但我也遇到了问题。

 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。 I＆＃39; m拉出的纸张中有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:\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

CREATE，POPULATE，EXPORT EXCEL TABLE （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

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

2 个答案: