'引用 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