[分享]数据导出到Excel

Public Function AccessToExcel(ByVal TempSql As String, Optional TempName As String)
'数据导出到Excel
'tempsql:支持sql语句\查询\表
'tempName:导出Excel的工作表的名称
'注意必须引用excel对象

    On Error GoTo Err:

    Dim row As Integer
    Dim col As Integer
    Dim Conn As ADODB.Connection

    Dim Rs As ADODB.Recordset

    Dim sql As String

    Dim ExcelApp As Excel.Application

    Dim ExcelWst As Worksheet  ''excel窗体

    Dim RsCount As Integer    ''记录数

    Set Conn = CurrentProject.Connection    '''本地连接

    If TempSql = "" Then Exit Function
    ' sql = TempSql ' "select * from 书本"

    Set Rs = CreateObject("ADODB.Recordset")

    Rs.Open TempSql, Conn, 1   ' 1 = adOpenKeyset

    Set ExcelApp = New Excel.Application
    Set ExcelWst = ExcelApp.Workbooks.Add.Worksheets(1)

    ExcelWst.Name = TempName

    For col = 0 To Rs.Fields.Count - 1
        ExcelWst.Cells(1, col + 1) = Rs.Fields(col).Name
    Next

    row = 2
    RsCount = Rs.RecordCount

    Rs.MoveFirst

    While Not Rs.EOF

        For col = 0 To Rs.Fields.Count - 1

            ExcelWst.Cells(row, col + 1) = Rs.Fields(col)

            ''转换日期型字符的表示格式
            If Rs.Fields(col).Type = 7 Then

                ExcelWst.Cells(row, col + 1).NumberFormatLocal = "yyyy-m-d;@"

            End If

        Next

        row = row + 1
        Rs.MoveNext
    Wend


    Rs.Close

    Set Rs = Nothing
    Set Conn = Nothing

    ExcelApp.Visible = True

Err:
    Exit Function
End Function