从Access中导出Excel文件的宏

最近需要从Access中抽出一些数据，手工操作太麻烦，所以写了宏来帮忙。

作用：

  将制定Table中的数据，作为检索条件，分别抽出数据并导出到Excel文件中。

Option Compare Database

Private Sub export()

    On Error GoTo ERROR_HANDLER
    
    Dim daoDB As Database
    Dim strac As String
    Dim varxls As Variant
    Dim rsErrSet As Recordset
    Dim strKey As String
    
    '　准备环境
    Set daoDB = DBEngine.Workspaces(0).Databases(0)
    
    '　取得需要处理的数据
    Set rsErrSet = daoDB.OpenRecordset("ERRLOG", dbOpenForwardOnly, dbReadOnly)
    
    Do Until rsErrSet.EOF
        Debug.Print rsErrSet!errcode & " " & rsErrSet!Key
        ' 生成导出Excel的Sheet名
        strac = rsErrSet!ID & "数据"
        If rsErrSet!Key <> "" Then
            ' 特殊文字替换
            strKey = Replace(rsErrSet!Key, "[", "*")
            strKey = Replace(strKey, "]", "")
            ' 做成检索
            daoDB.CreateQueryDef strac, _
                                 "SELECT [LIST].* FROM LIST WHERE [LIST].errcode like '*" & Right(rsErrSet!errcode, 8) & _
                                 "' and [LIST].msg like '*" & strKey & "*';"
        Else
            'クエリーの新規作成
            daoDB.CreateQueryDef strac, _
                                 "SELECT [LIST].* FROM LIST WHERE [LIST].errcode like '*" & Right(rsErrSet!errcode, 8) & "';"
        End If

        ' 设定导出文件名
        varxls = CurrentProject.Path & "\data.xls"
        ' 导出
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strac, varxls, True
        
        ' 删除检索
        daoDB.QueryDefs.Delete strac
        
        rsErrSet.MoveNext
    Loop
    ' 关闭
    daoDB.Close
    MsgBox "成功！"
    
    Exit Sub
    
ERROR_HANDLER:

    Debug.Print Err.Description
    MsgBox vbCrLf & Err.Description, vbCritical

End Sub