自己挑一下，意思应该是完整的。 有个别函数，你就重新写或者换成VB自带的函数。


Public Sub doExport(ByVal caption As String, ByVal text As String, ByVal MsgHwnd As Long, _
                    ByVal grid As DataGrid, _
                    ByVal rs As ADODB.Recordset)
  If UCase(TypeName(rs)) = "Nothing" Then
    Exit Sub
  End If
   
  If rs.Fields.Count = 0 Or grid.Columns.Count = 0 Then
    Exit Sub
  End If
    
  Dim Fn As String

  Fn = FileDialog.SaveDialog(MsgHwnd)
  If Fn = "" Then Exit Sub
  If Not EndWith(Fn, ".xls") Then Fn = Fn & ".xls"
    
  Dim xls As Excel.Application
  Dim w   As Excel.Workbook
  Dim e   As Excel.Worksheet
  
  Screen.MousePointer = 11
  On Error Resume Next
  Set xls = CreateObject("Excel.Application")
  If Err.Number <> 0 Then
    MsgBox "Sorry, create Excel object exception. Please check if Excel installed."
    Exit Sub
  End If
  On Error GoTo 0
  xls.Visible = True
  If fileExists(Fn) Then
    Set w = xls.Workbooks.Open(Fn)
  Else
    Set w = xls.Workbooks.Add()
  End If
        
  Set e = w.Worksheets.Add()
  
  Dim line As Long, iP As Integer
  line = 1
  
  If caption <> "" Then
    e.cells(line, grid.Columns.Count / 2) = caption
    line=line+1
  End If
  
  If text <> "" Then
    If grid.Columns.Count > 2 Then
      e.cells(line, CInt(grid.Columns.Count / 2) - 1) = text
    Else
      e.cells(line, grid.Columns.Count / 2) = text
    End If
    line=line+1
  End If
  
  For iP = 0 To grid.Columns.Count - 1
   e.cells(line, 1 + iP) = grid.Columns(iP).caption
  Next iP
  Call inc(line)
  
  If Not (rs.EOF And rs.BOF) Then
  Dim bm As Long
    bm = rs.Bookmark
    rs.MoveFirst
    Do While Not rs.EOF
      e.cells(line, 1) = rs.Fields("PName").value
      e.cells(line, 2) = rs.Fields("PAge").value
      e.cells(line, 3) = rs.Fields("PGender").value
      e.cells(line, 4) = rs.Fields("PPhone").value
      e.cells(line, 5) = rs.Fields("PContent").value
      e.cells(line, 6) = rs.Fields("FinishDT").value
      e.cells(line, 7) = rs.Fields("FinishBy").value
      e.cells(line, 8) = rs.Fields("PResult").value
      e.cells(line, 9) = rs.Fields("Remark1").value
      e.cells(line, 10) = rs.Fields("Remark2").value
      line=line+1
      rs.MoveNext
    Loop
    On Error Resume Next
    rs.MoveFirst
    If rs.Bookmark <> bm Then rs.Bookmark = bm
  End If

  e.Range("A1", "Z" & line).Columns.AutoFit
  On Error GoTo 0
  
  xls.DisplayAlerts = False
  If fileExists(Fn) Then w.Save Else w.SaveAs Fn
   
  w.Close
  xls.Quit
  Sleep 300
  
  Set w = Nothing
  Set xls = Nothing
  Screen.MousePointer = 0
End Sub

在程序中引用Microsoft Excel 9.0 Object Library，将下文加入到一个模块中,窗体中调用如下ExporToExcel("select * from table")。则实现快速将数据导出到EXCEL中。

Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
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
    
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        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
End Function

注:：在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000
本程序在Windows 98/2000,VB 6 下运行通过。

'引用 microsoft excel 9.0 object library 以上版本
'调用 call ExportToExcel(adodc1.recordset,"表格名称")或call ExportToExcel(ADODB.Recordset,"表格名称")
'如果是ADODB.Recordset 传递数据集，需要使用用户游标 rs.CursorLocation = adUseClient

Public Function ExportToExcel(Rs_Data As ADODB.Recordset, Titles_Name)
On Error GoTo ERRCL
Dim Irowcount As Long
Dim Icolcount As Long
    
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    
   ' 假设rs_data是你的记录集
    If Rs_Data.RecordCount < 1 Then
            MsgBox "没有可导出的记录!", vbInformation + vbOKOnly, "提示"
            Exit Function
        End If
        '记录总数
    Irowcount = Rs_Data.RecordCount
        '字段总数
    Icolcount = Rs_Data.Fields.Count
   
      
    
    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("a2"))
    xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 8)).Merge
    xlSheet.Cells(1, 1).HorizontalAlignment = xlCenter
    xlSheet.Cells(1, 1) = Titles_Name
    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(2, 1), .Cells(Irowcount + 2, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
        
       ' .PageSetup.PaperSize = xlPaperA4    '
       ' .PageSetup.PrintGridlines = True
    End With
xlApp.Application.Visible = True
   
    
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
  Exit Function
ERRCL:  MsgBox "无有效数据或 Excel 2000 未安装！", vbInformation, "错误"
End Function

http://blog.csdn.net/tt528/archive/2006/11/20/1398645.aspx

保存