记录集导出到Excel方法

记录集导出到Excel方法

 

Public Function ExportToExcel(RSrecord As ADODB.Recordset, Titles_Name)
'==================================================
'参数说明
'RSrecord ：记录集
'titles_name 表头名称
'==================================================
On Error GoTo ERRCL
Dim Rs_Data As New ADODB.Recordset
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 是你的记录集
With RSrecord
If .RecordCount < 1 Then
MsgBox "没有可导出的记录!", vbInformation + vbOKOnly, "提示"
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(RSrecord, 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
Set Rs_Data = Nothing
Exit Function
ERRCL: MsgBox "无有效数据或 Excel 2000 未安装！", vbInformation, "错误"
End Function