• Home
 · 
• Miscellaneous
 · 
• Export a recordset to Excel

Export a recordset to Excel

Export a recordset to Excel

Rate Export a recordset to Excel

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

   Dim appExcel As Excel.Application
   Dim wrkExcel As Excel.Workbook
   Dim shtExcel As Excel.Worksheet
   On Error Resume Next
   Set appExcel = GetObject(, "Excel.Application")
   If appExcel Is Nothing Then
       Set appExcel = CreateObject("Excel.Application")
       If appExcel Is Nothing Then
           MsgBox "Cannot Open Microsoft Excel For Export", vbCritical
           Exit Sub
       End If
   End If
   intNewSheets = appExcel.SheetsInNewWorkbook
   appExcel.SheetsInNewWorkbook = 1
   Set wrkExcel = appExcel.Workbooks.Add
   appExcel.SheetsInNewWorkbook = intNewSheets
   Set shtExcel = wrkExcel.Sheets(1)
   With shtExcel
       For intCount = 0 To rstReport.Fields.Count - 1
           shtExcel.Cells(1, intCount + 1).Value = rstReport.Fields(intCount).Name
           rstReport.MoveFirst
           For intRow = 1 To rstReport.RecordCount
               shtExcel.Cells(intRow + 1, intCount + 1).Value = rstReport.Fields(intCount).Value
               rstReport.MoveNext
           Next
       Next
       .Columns("A:" & Chr(64 + rstReport.Fields.Count)).Select
       .Columns("A:" & Chr(64 + rstReport.Fields.Count)).EntireColumn.AutoFit
       .Range("A1:" & Chr(64 + rstReport.Fields.Count) & "1").Select
   End With
   With appExcel.Selection.Interior
       .ColorIndex = 15
       .Pattern = xlSolid
   End With
   shtExcel.Select
   shtExcel.Name = lstReports.Text
   shtExcel.Range("A1").Select
   wrkExcel.Names.Add Name:="Print_Titles", RefersToR1C1:="=Sheet1!R1C1:R1C" & CStr(rstReport.Fields.Count)
   With shtExcel.PageSetup
       .PrintTitleRows = shtExcel.Rows(1).Address
       .PrintTitleColumns = ""
   End With
   shtExcel.PageSetup.PrintArea = ""
   With shtExcel.PageSetup
       .LeftHeader = ""
       .CenterHeader = strHeader
       .RightHeader = ""
       .LeftFooter = ""
       .CenterFooter = ""
       .RightFooter = ""
       .LeftMargin = Application.InchesToPoints(0.75)
       .RightMargin = Application.InchesToPoints(0.75)
       .TopMargin = Application.InchesToPoints(1)
       .BottomMargin = Application.InchesToPoints(1)
       .HeaderMargin = Application.InchesToPoints(0.5)
       .FooterMargin = Application.InchesToPoints(0.5)
       .PrintHeadings = False
       .PrintGridlines = True
       .PrintComments = xlPrintNoComments
       .PrintQuality = 600
       .CenterHorizontally = False
       .CenterVertically = False
       .Orientation = xlPortrait
       .Draft = False
       .PaperSize = xlPaperA4
       .FirstPageNumber = xlAutomatic
       .Order = xlDownThenOver
       .BlackAndWhite = False
       .Zoom = False
       .FitToPagesWide = 1
       .FitToPagesTall = False
   End With
   appExcel.DisplayFullScreen = True
   appExcel.DisplayFullScreen = False
   appExcel.Visible = True
   Set shtExcel = Nothing
   Set wrkExcel = Nothing
   Set appExcel = Nothing
End Sub