TransferSpreadsheet with columnwidth set (1 Viewer)

[Gismo]

Hi all,

I have quite a few queries that I transfer to excel
I want the column width to be set to Auto Fit

Below is the code and the module

Please could you advise if I am on the right track

Private Sub ExcelOpenItems_Click()
On Error GoTo ExcelOpenItems_Click_Err

Dim StrFileName As String
Dim StrQryName As String
Dim StrSaveFile As String

StrFileName = strGetFileFolderName("Open Items" & " - Registration -" & " " & Forms![CS Orders Detail - Main]![RegCBO], 2, "Excel")
'Debug.Print StrFileName
StrQryName = "Open Item QRY"

If Len(StrFileName & "") < 1 Then
StrFileName = Application.CurrentProject.Path & "\Open Items" & Format(Date, "yyyymmdd") & ".xls"
End If

Debug.Print "My File is:" & StrFileName
DoCmd.TransferSpreadsheet acExport, 10, StrQryName, StrFileName, True, , True


'Set column widths
DoCmd.OpenModule "AutoFitColumns"

ExcelOpenItems_Click_Exit:

Exit Sub

ExcelOpenItems_Click_Err:
MsgBox Error$
Resume ExcelOpenItems_Click_Exit
End Sub

Sub AutoFitColumns()

Dim sht As Worksheet

'AutoFit Every Worksheet Column in a Workbook
For Each sht In ThisWorkbook.Worksheets
sht.Cells.EntireColumn.AutoFit
Next sht

On Error GoTo 0

End Sub

 

[Gasman]

I doubt it.
You have no reference to excel whatsoever.
You need to reference Excel, open the workbook, select the worksheet, then autofit. Then save and close workbook, close Excel and set the objects to Nothing.

Also if you need to do this, you could try CopyFromRecordset as well, as TransferSpreadsheet is great when you do not have to open the Excel file, but now you do.?

 

[The_Doc_Man]

Gasman's answer is spot on. All I can add is that the properties of the sheet are not available unless you create an Excel object and actually open the workbook to select a sheet. Access is at least semi-object-oriented so there needs to be an appropriately opened object for it to find things like cells and columns in a worksheet.

 

[Pat Hartman]

Here's some Excel OLE automation code that does a variety of formatting. In an earlier procedure, the app uses TransferSpreadsheet to create the spreadsheet. This procedure is then called to open the file and add totals and do various formatting. The code uses optional early/late binding because the client had both 32 and 64 bit versions of Office installed and the app needed to run on both. I always use early binding whenever feasible since that is most efficient. You can use optional binding by simply copying the code prior to the on error goto statement. Then you have to pick and choose what formatting you need for your spreadsheet.

Just FYI, another reason for using late binding vs early binding is if your users have different versions of Office installed. Access will "promote" references but it will not "demote" them. For example, if you develop in A2019 but some of your users are still using A2010, you need to use late binding because the user will not be able to "demote" the reference from Excel 2019 to Excel 2010. However if you develop in A2010 but your users are running A2019, Access will be able to "promote" the Excel 2010 reference to Excel 2019.

Sorry to add the early/late binding to confuse you but this is otherwise the best code sample I have of automating Excel and I didn't want to modify the code in case I removed something important.

Private Sub FormatWeeklyJobStatus(sFileName)

Const xlDown = -4121
Const xlCellTypeLastCell = 11
Const xlThemeFontMinor = 2
Const xlPrintNoComments = -4142
Const xlPortrait = 1
Const xlPaperLegal = 5
Const xlPaperLetter = 1
Const xlOverThenDown = 2
Const xlPrintErrorsDisplayed = 0

    Dim sPath           As String
    Dim sTemplateName   As String
    Dim lngRows           As Long       'MUST be long
Dim ref As Reference

' 0 if Late Binding
' 1 if Reference to Excel set.
#Const ExcelRef = 0
#If ExcelRef = 0 Then ' Late binding
    Dim appExcel As Object     'Excel Object
    Dim wbkNew As Object    'Workbook Object
    Dim wksNew As Object    'Sheet Object
    Dim wbkTemplate As Object   'Workbook Object for Template

    Set appExcel = CreateObject("Excel.Application")
    ' Remove the Excel reference if it is present   -   <=======
    On Error Resume Next
    Set ref = References!Excel
    If Err.Number = 0 Then
        References.Remove ref
    ElseIf Err.Number <> 9 Then 'Subscript out of range meaning not reference not found
        MsgBox Err.Description
        Exit Sub
    End If
' Use your own error handling label here
On Error GoTo FormatWeeklyJobStatus_Error
#Else
    ' a reference to MS Excel <version number> Object Library must be specified
    Dim appExcel As Excel.Application      'Excel Object
    Dim wbkNew As Excel.Workbook        'Workbook Object
    Dim wksNew As Excel.Worksheet       'Sheet Object
    Dim wbkTemplate As Excel.Workbook   'Workbook Object for Template

    Set appExcel = New Excel.Application
#End If

    On Error GoTo FormatWeeklyJobStatus_Error

    sPath = DLookup("Database", "MsysObjects", "[Name] = 'tblJob'")
    sPath = Left(sPath, InStrRev(sPath, "\"))
    sTemplateName = sPath & "WeeklyJobStatusHeaders.xlsx"

    Set wbkNew = appExcel.Workbooks.Open(sFileName)
    Set wksNew = appExcel.Worksheets("qWeeklyJobStatusReportExcel")
   
    'remove column names - some bug is preventing HasFieldNames argument from working on the export
    If wksNew.Range("A1").Value = "ContractName" Then
        appExcel.Rows("1:1").Select
        appExcel.Rows("1:1").Delete
    End If
   
    ' Insert 5 rows at top to make room for headers
    With appExcel

        .Rows("1:1").Select
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
       
        ' Get headers from template file
        Set wbkTemplate = .Workbooks.Open(sTemplateName)
        wbkTemplate.Activate
        .Rows("1:5").Select
        .Selection.Copy
       
        ' Paste into new Workbook.
        wbkNew.Activate
        .ActiveSheet.Paste
       
        ' Close template
        .CutCopyMode = False    'clear clipboard to get rid of warning message
        wbkTemplate.Close
       
        'add job name
        .Range("A5").Value = Me.cboJob.Column(3)
       
        ' Count rows in new Workbook.
        .Selection.SpecialCells(xlCellTypeLastCell).Select
        lngRows = .Selection.Row
       
        'insert sum functions
            'the reference style below uses the current position so we subtract the number of rows (lngRows)
            'to get to the top and then add 5 to get past the headers
        .Cells(lngRows + 1, 4).Select     'column D - Total plan pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 5).Select     'column E - OFA pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 6).Select     'column F - BFA pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 7).Select     'column G - Issued to Shop pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 9).Select     'column I - Cut Issue pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 11).Select     'column K - Fitted pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 12).Select     'column L - Welded pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Cells(lngRows + 1, 13).Select     'column M - Shipped pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
       
        .Range("A" & lngRows + 1 & ":N" & lngRows + 1).Select
       
       
        ' Freeze panes
        .Range("A6").Select
        .ActiveWindow.FreezePanes = True
       
        ' Header should print on every page when in Print Preview
        .ActiveSheet.PageSetup.PrintTitleRows = "$1:$5"
        .ActiveSheet.PageSetup.PrintTitleColumns = ""
       
       'format cells as numeric
        .Cells.NumberFormat = "#,##0_);[Red](#,##0)"
       
        ' Set format for date columns
        wksNew.Columns("H").NumberFormat = "d-mmm;@"
        wksNew.Columns("J").NumberFormat = "d-mmm;@"
           
        ' Set font and size
        .Cells.Select
        With .Selection.Font
            .Name = "Calibri"
            .Size = 11
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
       
        ' Set page setup properties
        .Columns("A:N").Select
        .Selection.Columns.AutoFit
       
        With .ActiveSheet.PageSetup
            .PrintArea = "$A$1:$N$" & CStr(lngRows + 2)
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
            .LeftMargin = appExcel.InchesToPoints(0.5)
            .RightMargin = appExcel.InchesToPoints(0.5)
            .TopMargin = appExcel.InchesToPoints(0.5)
            .BottomMargin = appExcel.InchesToPoints(0.5)
            .HeaderMargin = appExcel.InchesToPoints(0.5)
            .FooterMargin = appExcel.InchesToPoints(0.5)
            .PrintHeadings = False
            .PrintGridlines = True
            .PrintComments = xlPrintNoComments
           ' .PrintQuality = 600
            .CenterHorizontally = False
            .CenterVertically = False
            .Orientation = xlPortrait
            .Draft = False
            .PaperSize = IIf(lngRows > 44, xlPaperLegal, xlPaperLetter)
            .FirstPageNumber = xlAutomatic
            .Order = xlOverThenDown                         ' Change order to print all "page 1" before "page 2"
            .BlackAndWhite = False
            ''.Zoom = 80                                      ' Shrink down a little
            .Zoom = False                                   ' Should not need both
            .FitToPagesWide = 1
            .FitToPagesTall = False
            .PrintErrors = xlPrintErrorsDisplayed
        End With
    End With

    wbkNew.Save

FormatWeeklyJobStatus_Exit:
    On Error Resume Next
    ' Required for cleanup.
    wbkNew.Close
    Exit Sub

FormatWeeklyJobStatus_Error:
    Select Case Err.Number
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatWeeklyJobStatus of VBA Document Form_frmReports"
    End Select

    Resume FormatWeeklyJobStatus_Exit
End Sub