利用一个按钮将acess查询后的结果导出到excel.....高分！！！

Public Sub ExportToExcel(ado As Adodc, DG As DataGrid, startCol As Integer, EndCol As Integer, StrTitle As String)
'输出到EXCEL表中
'数据来源于ado和dg，strtitle为第一行第一列显示的内容，即表名
'startCol为要导出的dataGrid的起始列，可能会需要不导出数据的前几列
'endCol为要导出的dataGrid的终止列Dim Excel_File As New Excel.Application
Dim Excel_WorkBook As Excel.Workbook
Dim Excel_Sheet As Excel.Worksheet
Dim savename, s As String
Dim j, k As Integer
Dim jindu, k1 As Single'创建excel文件
Frm_Main.CommonDialog1.filename = StrTitle
Frm_Main.CommonDialog1.Filter = "*.xls|*.xls"
Frm_Main.CommonDialog1.CancelError = True
On Error GoTo L1
Frm_Main.CommonDialog1.DialogTitle = "输入要创建的Excel文件名"
Frm_Main.CommonDialog1.FilterIndex = 2
Frm_Main.CommonDialog1.ShowSave
L1:
If err.Number = cdlCancel Then
err.Clear
Exit Sub
End If
If Frm_Main.CommonDialog1.filename = "" Then Exit Sub
savename = Frm_Main.CommonDialog1.filename
''拆分savenae并判　断有无此文件
If IsSaveFileNameExist(savename) = True Then
MsgBox "已有此文件，另输入一个文件名。"
Exit Sub
End IfFileCopy App.path & "\table.xls", savename'打开创建的文件并输出
On Error GoTo 100
If ado.Recordset.RecordCount = 0 Then
MsgBox "无记录。", vbInformation + vbOKOnly, DlgTitle
Exit Sub
End If
Frm_JinDu.Show
Frm_JinDu.Command2.Enabled = False
Frm_JinDu.MousePointer = 11
'进度还原
Frm_JinDu.Label3.Width = 0
If ado.Recordset.RecordCount <= 0 Then
Exit Sub
End If
jindu = 100 / ado.Recordset.RecordCount
Frm_JinDu.Label1.Caption = "准备导出..."
Set Excel_File = CreateObject("Excel.application")
If Excel_File Is Nothing Then
MsgBox "请检查是否安装microsoft EXCEL软件", , DlgTitle
Exit Sub
End If
On Error GoTo 100
Set Excel_WorkBook = Excel_File.Workbooks.Open(savename)
If Excel_WorkBook Is Nothing Then
MsgBox "请检查是否存在" & savename & "文件。", , DlgTitle
Exit Sub
End If
Set Excel_Sheet = Excel_WorkBook.Worksheets("Sheet1")
If Excel_Sheet Is Nothing Then
MsgBox "请检查 " & savename & " 文件中SHEET1是否存在。", , DlgTitle
Exit Sub
End If
Excel_File.Sheets("Sheet1").Select
Excel_File.Range("A1:U100").Select
Excel_File.Selection.ClearContents
Excel_File.Range("A4").Select
s = "B2"
Excel_Sheet.Range(s).Font.Size = 12
Frm_JinDu.Label1.Caption = "正在导出..."
'表头
Excel_Sheet.Cells(1, 1) = StrTitle
For j = 0 To 0
DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
DG.Col = k
Excel_Sheet.Cells(j + 2, k + 1 - startCol) = DG.Columns(k).Caption
Next k
Next j
'表资料
ado.Recordset.MoveFirst
For j = 0 To ado.Recordset.RecordCount - 1
'DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
'DG.Col = k
Excel_Sheet.Cells(j + 3, k + 1 - startCol) = ado.Recordset.Fields(k).Value 'DG.Text
Next k
'显示进度
Frm_JinDu.Label3.Width = Frm_JinDu.Label3.Width + Frm_JinDu.Picture1.Width / ado.Recordset.RecordCount
k1 = k1 + jindu
DoEvents
Frm_JinDu.Label4.Caption = CInt(k1) & "%"
ado.Recordset.MoveNext
Next jExcel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Frm_JinDu.Label1.Caption = "导出完成，数据被导入" & savename & "中。"
Frm_JinDu.Command2.Enabled = True
Frm_JinDu.Command2.SetFocus
Frm_JinDu.MousePointer = 0Exit Sub100:
MsgBox "导出出错。"
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Unload Frm_JinDu

S_Out = "select 发货序号,convert(char(10),发货日期,111) as 发货日期,收货单位,订单号码,品名,规格,重量,单位,单价,总价 as 含税总价,含税,包装,箱数,结帐 as 对账,开票,作废,备注 from md_send_dj "
Call ExporToExcel(S_Out, Connection)    'S_Out为查询语句；Connection为联接字符串
Public Function ExporToExcel(strOpen As String,connection As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
'Dim cn As New ADODB.Connection
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
   ' cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source ='" + App.Path & "\info.mdb" + "'  ;Persist Security Info=False"
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Connection
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
  '  Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
    With Rs_Data
      '  .MoveFirst
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True
    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With    'With xlSheet.PageSetup
    '    .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：无锡巨丰漆包线厂"   ' & Gsmc
    '    .CenterHeader = "&""楷体_GB2312,常规""发货情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日期："
    '    .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
    '    .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
    '    .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
    '    .RightFooter = "&""楷体_GB2312,常规""&10第&P页共&N页"
    'End With
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing

    'Dim P As Integer, P1 As Integer
    'Dim Str_Temp As String

    'Str_Temp = FileName
    'P = 0
    'P1 = 0
    'For i = 1 To Len(FileName)
    '   P1 = InStr(1, Mid(Str_Temp, 1, (Len(FileName) - P)), "\")
    '   If P1 > 0 Then
    '      P = P1 + P
    '      Str_Temp = Right(Str_Temp, (Len(Str_Temp) - P1))
    '   Else
    '      Exit For
    '   End If
    'Next

    'If P > 0 Then ChDir Left(FileName, (P - 1))
    'ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlNormal _
    '    , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    '    CreateBackup:=False

End Function

Set xlsapp = CreateObject("Excel.Application")
    Set xlsWorkbook = xlsapp.Workbooks.Add
    Set xlsWorksheet = xlsWorkbook.Worksheets(1)

    frmForm.lblCaption.Caption = "填充数据......"
'        xlsapp.Visible = True
    With lvwListView

        xlsWorksheet.Range(xlsWorksheet.Cells(1, 1), xlsWorksheet.Cells(1, .ColumnHeaders.Count)).Font.FontStyle = "加粗"
        xlsWorksheet.Cells.Font.Name = "Arial"
        xlsWorksheet.Cells.Font.Size = 10

        For lngRow = 1 To .ListItems.Count
            For lngCol = 1 To .ColumnHeaders.Count - 1

                If lngFlag = 0 Or InStr(strFields, .ColumnHeaders(lngCol + 1).TEXT) <> 0 Then
                    xlsWorksheet.Cells(lngRow + 1, lngCol).NumberFormatLocal = "@"
                Else
                    xlsWorksheet.Cells(lngRow, lngCol).NumberFormatLocal = "0.00"
                End If                If .ColumnHeaders(lngCol + 1).Width <> 0 Then
                    If lngRow = 1 Then
                        xlsWorksheet.Cells(lngRow, lngCol) = .ColumnHeaders.Item(lngCol + 1).TEXT
                    End If
                    xlsWorksheet.Cells(lngRow + 1, lngCol) = Trim(.ListItems(lngRow).SubItems(lngCol))
                End If

                frmForm.prgProgress.Value = frmForm.prgProgress.Value + 1

            Next

        Next    End With
可以将上面的代码当做一个过程
然后用的时候，
     Call subExpertToExcel(Me, lvwlist)
     Call 过程名字（窗体名称、控件名称）

Option ExplicitPrivate Sub Command1_Click()
        Dim Conn As New ADODB.Connection
        Dim Rs As New ADODB.Recordset
        Dim ExcelApp As New Excel.Application
        Dim WorkBookObj As Workbook
        Dim SheetObj As Worksheet


        Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\aa.mdb"
        Conn.Open
        Rs.Open "Select * From aa", Conn, adOpenKeyset, adLockOptimistic, adCmdText
        '==========================================================================
        Set WorkBookObj = ExcelApp.Workbooks.Open(App.Path & "\bbb.xls")
        Set SheetObj = WorkBookObj.Worksheets(1)
        '========================================
        SheetObj.Range("A1").CopyFromRecordset Rs
        '========================================
        Set SheetObj = Nothing
        WorkBookObj.Save
        WorkBookObj.Close
        Set WorkBookObj = Nothing
        ExcelApp.Quit
        Set ExcelApp = Nothing
        Rs.Close
        Set Rs = Nothing
        Conn.Close
        Set Conn = Nothing
        MsgBox "OK!请您打开bbb.xls文件察看!"
End Sub

调试易

利用一个按钮将acess查询后的结果导出到excel.....高分！！！

解决方案 »