Access VBA DLC- Excel篇 使用Access操作Excel

Private Sub Command2_Click()

    Dim ex As Object, wb As Workbook, sht As Worksheet, path_name As String, fdialog As Object

    t = Timer

    Set fdialog = Access.Application.FileDialog(msoFileDialogFilePicker)

    With fdialog

        .initialfilename = CurrentProject.Path

        .allowmultiselect = False

        .Filters.Clear

        .Filters.Add "excel文件", "*.xlsx;*.xls"

        If .Show = True Then

            Me.Text0 = .selecteditems(1)

        Else

            MsgBox "没有选择文件，程序退出"

            Exit Sub

        End If

    End With

    Set ex = CreateObject("excel.application")

    Set wb = ex.Workbooks.Open(Me.Text0)

'    ex.ScreenUpdating = False

    Dim rs As New ADODB.Recordset

    Dim link As New ADODB.Connection

    前缀 = "select * from ["

    后缀 = "$] union all "

    For Each sht In wb.Worksheets

        SQL = SQL & 前缀 & sht.Name & 后缀

    Next

    SQL = Left(SQL, Len(SQL) - 11)

    Debug.Print SQL

    link.Open "Provider=Microsoft.ACE.OLEDB.12.0;Persist Security Info=False;Data Source=" & Me.Text0 & ";Extended Properties='Excel 12.0;HDR=Yes'"

    rs.Open SQL, link, 1, 3

    wb.Sheets.Add.Name = "合并"

    For i = 0 To rs.Fields.Count - 1

        wb.Sheets("合并").Cells(1, i + 1) = rs.Fields(i).Name

    Next

    wb.Sheets("合并").Range("a2").CopyFromRecordset rs

    Debug.Print rs.RecordCount

    rs.Close

    link.Close

    wb.Save

    wb.Close

'    ex.ScreenUpdating = True

    MsgBox "处理完成" & Round(Timer - t, 2) & "s"

    Set ex = Nothing

    Set wb = Nothing

    Set link = Nothing

    Set wb = Nothing

End Sub