Access培訓
網站公告
·Access快速平臺QQ群號:277422564    ·Access快速開發平臺下載地址及教程    ·歡迎添加微信交流賬號:AccessoftChu    ·如何快速搜索本站文章|示例|資料    
您的位置: 首頁 > 技術文章 > Access數據庫-模塊/函數/VBA

導出至Excel系列方法六QueryTables

時 間:2019-10-03 11:05:25
作 者:金宇   ID:43  城市:江陰
摘 要:此方法是借用Excel中QueryTables對象的Add方法實現將數據導出至Excel。
正 文:

      此方法是借用Excel中QueryTables對象的Add方法實現數據的導出,將 ADO 或 DAO Recordset(記錄集) 對象從指定區域的左上角開始創建新的查詢表,導出數據到Excel時帶有標題。

關于此對象的add方法的使用我寫了一個專門的函數,可以直接調用便于數據導出至Excel,調用方法如下:

ExportToExcelQueryTables "Products", "select [Supplier IDs],ID,[Product Code],[Product Name],[Description] from Products"


"Products" 就指工作薄的名稱。
"select [Supplier IDs],ID,[Product Code],[Product Name],[Description] from Products" 是需要導出數據的SQL語句。


函數如下:

'===============================================================================
'函數名稱: ExportToExcelQueryTables
'功能描述: 將SQL語句創建的記錄集對象中的內容復制到Excel工作表
'輸入參數: WorkbookName 必需的,工作簿名稱
'           strSQL       必需的,不能包含具有 OLE 對象的字段,否則該方法無效。
'返回參數: 無
'使用說明: ExportToExcelQueryTables("公司資料","select * from 表名稱或者查詢名稱")
'作    者: 金宇
'創建日期: 2013-11-1
'===============================================================================
Function ExportToExcelQueryTables(ByVal WorkbookName As String, ByVal strSQL As String)
On Error GoTo Err_ExportToExcel
    Dim objExcel As Object
    Dim objBook  As Object
    Dim objSheet As Object
    Dim objRange As Object
    Dim objExcelQuery As Object
    Dim rst      As Object
    Dim cnn      As Object
    Dim strFileName As String
    Dim strExtName As String
    
    Dim lngRow As Long
    Dim lngColumn As Long
    Dim FirstRange As String

  

    If Dir(WorkbookName) <> "" Then Kill WorkbookName
    '根據當前版本取得對應的文件擴展名
    strExtName = ".xls"
    If Val(Application.Version) > 11 Then strExtName = ".xlsx"
    '取得另存為文件名
    With Application.FileDialog(2) 'msoFileDialogSaveAs
        .InitialFileName = WorkbookName & strExtName
        If Not .Show Then Exit Function
        strFileName = .SelectedItems(1)
        If Not strFileName Like "*" & strExtName Then
            strFileName = strFileName & strExtName
        End If
        If Len(Dir(strFileName)) > 0 Then Kill strFileName
    End With

    DoCmd.Hourglass True

    'ADO方式
    Set rst = CreateObject("adodb.recordset")
    Set cnn = CurrentProject.Connection
    'CursorLocation = 3 這段代碼必須加否則會出錯,
    '如果不加會在objSheet.QueryTables.Add那里會出現 "無效的過程調用或參數"
    rst.CursorLocation = 3
    rst.Open strSQL, cnn, 1, 1

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    Set objBook = objExcel.Workbooks.Add
    Set objSheet = objBook.Worksheets.Add
    'Set objSheet = objBook.Worksheets("Sheet1")
    objSheet.Name = WorkbookName '工作表名稱
    objSheet.Select
    Set objExcelQuery = objSheet.QueryTables.Add(rst, objSheet.Range("A1"))
    With objExcelQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With


    objExcel.Visible = True
    objBook.SaveAs strFileName

    
Exit_ExportToExcel:
    Set rst = Nothing
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objExcel = Nothing
    
    DoCmd.Hourglass False
    Exit Function
    
Err_ExportToExcel:
    MsgBox Err.Description, vbCritical, "錯誤提示"
    Resume Exit_ExportToExcel
End Function

測試示例下載:

點擊下載此附件



Access軟件網官方交流QQ群 (群號:864245409)       access源碼網店

最新評論 查看更多評論(0)

發表評論您的評論將提升作者分享的動力!快來評論一下吧!

用戶名:
密 碼:
內 容:
 

常見問答

技術分類

相關資源

關于我們 | 服務條款 | 在線投稿 | 友情鏈接 | 網站統計 | 網站幫助