Access to Excel export with proper formatting 6

[djmousie]

The below code exports information for me from Access to Excel, and this works perfectly, however, I need for the export to properly format my excel sheets before the export (bolding, column sizes,etc.). Based on the coding below, what would I need to add to this in order for this to work?

Private Sub Command4_Click()
Dim db As DAO.Database, rs As DAO.Recordset, str1Sql As QueryDef, strCrt As String, strDt As String
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT DISTINCT field1 FROM table ORDER By field1;")
strDt = Format(Month(Date), "00") & Format(Day(Date), "00") & Format(Year(Date), "00")
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
strCrt = rs.Fields(0)
Set str1Sql = db.CreateQueryDef("" & strCrt, "SELECT table.* FROM table WHERE table.field1 = '" & strCrt & "';")
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "" & strCrt, "C:\file " & strCrt & ".xls", True
DoCmd.DeleteObject acQuery, "" & strCrt
rs.MoveNext
Loop
End Sub

 

[ohtechie]

Ok sounds like this has been around a little while so i'm going to put my 2 cents in. I had to do something similar to this and what I ended up doing is to add the excel object to the routine and then a few lines to format the columns as needed then delete the query def as in your example before the rs. next statement. worked for my needs (multiple sheets as well as multiple workbooks) i'll dig through my code to see if i can find the routine i used if you would like to see it. my code is longer than what your needing i think as i have 40 columns i'm dealing with all with different widths and formatting.

 

[djmousie]

that would be much appreciated!

Thanks

 

[fldbryan]

My solution was to do something like this.

Function MakeSS_ALEADER()
    ' Declare an object variable to hold the object
    ' reference. Dim as Object causes late binding.
    DoCmd.Hourglass True
    DoCmd.OpenForm "frmWorking"
    DoCmd.RepaintObject acForm, "frmWorking"
    Dim ExcelSheet As Object, XL As Object
    
    Dim DB
    Dim RS
    
    Dim X
    
    X = 0
    
    Set DB = CurrentDb()
    Set RS = DB.OpenRecordset("Select * from qrySelectReqReportOpen_ALL ORDER BY [Area Leader], [Req#]", dbOpenDynaset, dbReadOnly)
    Set XL = CreateObject("Excel.Application")
    'Set ExcelSheet = CreateObject("Excel.Sheet")
    Set ExcelSheet = XL.Workbooks.Add("C:\templates\aleader.XLT")

    'open up template
    'ExcelSheet.Application.Workbooks.Open "C:\AL.XLT"

    Do Until RS.EOF
        X = X + 1
        'populate excel row
        ExcelSheet.Sheets(1).Cells((X + 1), 1).Value = X
        ExcelSheet.Sheets(1).Cells((X + 1), 2).Value = RS("Req#")
        ExcelSheet.Sheets(1).Cells((X + 1), 3).Value = RS("opened")
        ExcelSheet.Sheets(1).Cells((X + 1), 4).Value = RS("targethiredate")
        ExcelSheet.Sheets(1).Cells((X + 1), 5).Value = RS("Status")
        ExcelSheet.Sheets(1).Cells((X + 1), 6).Value = RS("Position")
        ExcelSheet.Sheets(1).Cells((X + 1), 7).Value = RS("Hiring Manager")
        ExcelSheet.Sheets(1).Cells((X + 1), 8).Value = RS("Area Leader")
        ExcelSheet.Sheets(1).Cells((X + 1), 9).Value = RS("Cost Center")
        ExcelSheet.Sheets(1).Cells((X + 1), 10).Value = RS("Department")
        ExcelSheet.Sheets(1).Cells((X + 1), 11).Value = RS("Recruitor1")
        ExcelSheet.Sheets(1).Cells((X + 1), 12).Value = RS("Location")
                
        'Move to next record
        RS.MoveNext
    Loop
    ' Save the sheet to C:\ directory.
    ExcelSheet.Application.DisplayAlerts = False
    ExcelSheet.SaveAs "C:\ALEADER.XLS"
    ExcelSheet.Application.DisplayAlerts = True
    'ExcelSheet.Application.View
    On Error Resume Next
    ' Close Excel with the Quit method on the Application object.
    ExcelSheet.Application.Quit
    RS.Close
    DB.Close
    ' Release the object variable.
    Set ExcelSheet = Nothing
    Set RS = Nothing
    Set DB = Nothing
    DoCmd.Close acForm, "frmWorking"
    DoCmd.Hourglass False
    MsgBox "Area Leader created on C:\ALEADER.XLS"
    X = Shell("excel.exe c:\aleader.xls", vbMaximizedFocus)
End Function

 

[CompuSolve]

I do this fairly often. I create the query and export it to excel. You than open the excel sheet, select, 'Tools/Macros/Record New Macro' and make your formatting changes. You end the recording, hit ALT-F11 to get into code view and view the VBA generated in module1 in the 'modules' section. This will give you the starting point to recreating the code in Access. For simple formatting - i.e., resize columns, bold headers, freeze panes, you can have a simple sub that does the work for you and call it.

Public Sub FormatExcelBasic(fileIn As String, sheetIn As String)

'you must add a reference to excel in your project for this to work
'i.e. Microsoft Excel 11.0 Object Library

'fileIn is the fullpath and name of the excel file

'sheetIn is the name of the worksheet you are trying to format - typically this
'is the first 31 characters of the query you exported with the
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9,... command in a different sub

'if you run this code against any excel spreadsheet: FormatExcelBasic "c:\test.xls", "testsheet"
'the test sheets will end up with autofitted columns and frozen, bolded, aqua headers

On Error GoTo errHan
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRange As Excel.Range
Dim lngLastRow As Long
Dim strCell As String

Set xlApp = New Excel.Application
xlApp.Visible = False

Set xlBook = xlApp.Workbooks.Open(fileIn)

Set xlSheet = xlBook.Sheets(sheetIn)

'rename the sheet to something more friendly to humans
xlBook.Sheets(sheetIn).NAME = "New Sheet Name"

'this will give you the last row used on the spreadsheet
'in case you want to programatically create a total line - there must
'be something in column A for this to work, of use another column that
'has data in every row
lngLastRow = xlSheet.Range("A65536").End(xlUp).Row

'select the first row
Set xlRange = xlSheet.Rows(1)
'bold the selection, set the font and fontsize, center all the cells
xlRange.Font.Bold = True
xlRange.Font.Size = 10
xlRange.Font.NAME = "Verdana"
xlRange.HorizontalAlignment = xlCenter

'stretch all the cells to 30 - this maks the auto work better
xlSheet.Cells.EntireColumn.ColumnWidth = 30
'autofit the columns
xlSheet.Cells.EntireColumn.AutoFit

'freeze the pane so the header row doesn't scroll
xlSheet.Activate
xlSheet.Range("A2", "A2").Select
xlApp.ActiveWindow.FreezePanes = True

'the following code is some examples of different things to do in VBA
'with the Excel object - some stuff will repeat - this is just a bunch of samples

'do some settins for the page layout when printing
With xlSheet.PageSetup
        .LeftHeader = "Left Header Here"
        .CenterHeader = "Center Header Here"
        .CenterFooter = "Page &P" 'print the page number bottom center
        .LeftMargin = xlApp.InchesToPoints(0.25)
        .RightMargin = xlApp.InchesToPoints(0.25)
        .TopMargin = xlApp.InchesToPoints(1)
        .BottomMargin = xlApp.InchesToPoints(1)
        .HeaderMargin = xlApp.InchesToPoints(0.5)
        .FooterMargin = xlApp.InchesToPoints(0.5)
        .PrintQuality = 600
        .Orientation = xlLandscape
        .PaperSize = xlPaperLegal
        .FirstPageNumber = xlAutomatic
        .Order = xlOverThenDown
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .PrintGridlines = True
End With

'some examples of setting formats for columns
Set xlRange = xlSheet.Columns("N:N")
xlRange.NumberFormat = "$#,##0"
Set xlRange = xlSheet.Columns("L:M")
xlRange.NumberFormat = "#,##0"
Set xlRange = xlSheet.Columns("CG:CK")
xlRange.NumberFormat = "0.0%"

'some more formating - sets the entire sheetfont, then bolds the header
Set xlRange = xlSheet.Cells.EntireRow
xlRange.Font.NAME = "Arial"
xlRange.Font.Size = 8
Set xlRange = xlSheet.Rows("1:1")
xlRange.Font.FontStyle = "Bold"
xlRange.Interior.ColorIndex = 8
xlRange.HorizontalAlignment = xlCenter

'This is how you can draw some borders around a selected range
With xlRange.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With xlRange.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With

With xlRange.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With xlRange.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With xlRange.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With

'this is how you can set the headers on specific columns
xlSheet.Cells(1, 1).Value = "Header 1"
xlSheet.Cells(1, 2).Value = "Header 2"

'some more auofitting and freezing
xlSheet.Cells.EntireColumn.ColumnWidth = 30
'autofit the columnms
xlSheet.Cells.EntireColumn.AutoFit
'lock the first row
xlSheet.Activate
xlSheet.Range("A2", "A2").Select
xlApp.ActiveWindow.FreezePanes = True

'need to save all the changes and release all the variables
'*****
'IF YOU DO NOT RELEASE ALL THE VARIABLE IN THE CORRECT ORDER, YOU WILL
'END UP WITH INVISBLE EXCEL SESSIONS THAT NEVER CLOSE
'the invisible sessions can be killed from task manager, but you
'should try to always get the excel object killed before exiting the sub

xlBook.Save
Set xlRange = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing

Exit Sub
errHan:
    MsgBox Err.Number & " - " & Err.Description & vbCrLf & vbCrLf & _
    "Error occurred during FormatExcelBasic function.", vbCritical, "Error!"

'if there was an error, need to save whatever changes we made and clear the
'variables
'IF YOU DO NOT RELEASE ALL THE VARIABLE IN THE CORRECT ORDER, YOU WILL
'END UP WITH INVISBLE EXCEL SESSIONS THAT NEVER CLOSE
'the invisible sessions can be killed from task manager, but you
'should try to always get the excel object killed before exiting the sub
   On Error Resume Next
   xlBook.Save
   Set xlRange = Nothing
   Set xlSheet = Nothing
   Set xlBook = Nothing
   xlApp.Quit
   Set xlApp = Nothing
   Exit Sub
   
   Resume
End Sub