记录集导出到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

转载于:https://www.cnblogs.com/dabaixiong/p/5577639.html