Query Export > Excel & Format as table (or filter/sort columns) > Save & Close (1 Viewer)

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
Hi everyone,

Im currently looking into exporting a simple query to excel (weekly orders status)

Im hoping for:

Export on click
custom filename
Open & format as table
Close and Save
maybe open MS outlook and attach to an email

Im following a Youtube tutorial by "Access Jitsu" using the TransferSpreadsheet method but i know these videos do not cover formatting as a table

I have recorded the macro in excel and will be trying to figure it out myself later but i thought in the meantime if anyone has any useful advice or links i would appreciate it.

Thanks in advance everyone
 

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
I use this as part of a routine that will either open a query or export it and format it as a table.

Call it using the Query name as a string, and a save name.
Save it all in a module (mod_ExcelExport?)

The second function is a pretty direct answer to your question.
SQL:
Option Compare Database
Option Explicit

 
Const xlLandscape    As Long = 2
Const xlCenter       As Long = -4108
Const xlBottom       As Long = -4107
Const xlContext      As Integer = -5002
Const xlDown         As Integer = -4121
Const xlContinuous   As Integer = 1
Const xlThin         As Integer = 2
Const xlLastCell     As Long = 11
Const xlYes          As Long = 1
Const xlSrcRange     As Long = 1
Const xlMaximized    As Integer = -4137   ' Maximized
Const xlMinimized    As Integer = -4140   ' Minimized
Const xlNormal       As Integer = -4143   ' Normal
Public bOverWrite    As Boolean
Public bOpenFile     As Boolean
Global glDb As DAO.Database
 
'Report handling all queries / report selecting moved to one module for simplicity

Public Sub ListReporter(qryName As String, qrySaveName As String, XLExport As Integer)

    Dim txtQueryName     As String
    Dim strSaveFile      As String
    Dim sSql             As String
    Dim sComputerName    As String
    Dim iResp            As Integer
    Dim sRange           As String
    Dim sUser            As String
 
    On Error GoTo ListReporter_Error
    bOpenFile = True
    If glDb Is Nothing Then Set glDb = CurrentDb
 
    txtQueryName = Left(Replace(qryName, " ", "_"), 30)  'Remove any spaces as spaces in the sheet name cause issues.
 
    strSaveFile = (CurrentApplication.Path & "\" & qrySaveName & "_" & Format(Date, "yyyymmdd")) & ".xlsx"


    If Not XLExport Then
        DoCmd.OpenQuery qryName, acViewNormal, acReadOnly
    Else

        If IsFileOpen(strSaveFile) Then
            MsgBox "The file " & strSaveFile & " is currently open." & vbCrLf & "Please close it before trying to overwrite it!!", vbInformation, "File Open!"
            Exit Sub
        End If
     
        If FileExists(strSaveFile) Then
            If bOverWrite Then
                Kill strSaveFile
            Else
                iResp = MsgBox("This file is already saved, do you want to delete it first? " & vbCrLf & _
                    "Selecting no will retain any formatting, but may result in an error if you have any summary or total fields added to the existing version", vbYesNo, "File Exists!")
                If iResp = vbYes Then
                    Kill strSaveFile
                End If
            End If
        End If
     
        sRange = txtQueryName
        DoCmd.TransferSpreadsheet acExport, 10, qryName, strSaveFile, True, sRange, True
     
        'Debug.Print "here1"
        If Not bOpenFile Then
            Call XLFormatTable(strSaveFile, txtQueryName, False)
        Else
            If MsgBox("Your file has been saved in the c:\ExcelSaves folder, do you want to open it ?", vbYesNo, "Reports") = vbYes Then
                Call XLFormatTable(strSaveFile, txtQueryName, True)
            Else
                Call XLFormatTable(strSaveFile, txtQueryName, False)
         
            End If
        End If
     
    End If
 
    On Error GoTo 0
    Exit Sub

ListReporter_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ListReporter of ReportLogger"

End Sub


Public Sub XLFormatTable(sFile As String, sSheet As String, Optional bOpen As Boolean = True)

    On Error GoTo XLFormatTable_Error
    ' Late binding to avoid reference:
    Dim xlApp            As Object        'Excel.Application
    Dim xlWb             As Object        'Workbook
    Dim xlWS             As Object        'Worksheet
    Dim tbl              As Object
    Dim rng              As Object
    
    'Debug.Print sFile, sSheet
    
    ' Create the instance of Excel that we will use to open the temp book
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = bOpen
    Set xlWb = xlApp.Workbooks.Open(sFile)
    'Debug.Print xlWB.Name
    Set xlWS = xlWb.Worksheets(sSheet)

    ' Format our temp sheet
    ' ************************************************** *************************

    xlApp.Range("A1").Select

    With xlWS
        '        With .UsedRange
        '            .borders.LineStyle = xlContinuous
        '            .borders.ColorIndex = 0
        '            .borders.TintAndShade = 0
        '            .borders.Weight = xlThin
        '        End With
        '
        '        'format header 90 degree
        '        With .Range("i1:y1")
        '            .HorizontalAlignment = xlCenter
        '            .VerticalAlignment = xlBottom
        '            .WrapText = False
        '            .Orientation = 90
        '            .AddIndent = False
        '            .IndentLevel = 0
        '            .ShrinkToFit = False
        '            .ReadingOrder = xlContext
        '            .MergeCells = False
        '        End With
        '        .UsedRange.Rows.RowHeight = 15
        '        .UsedRange.Columns.AutoFit

        With xlWb.Sheets(sSheet)
            Set rng = .Cells(1, 1).CurrentRegion
        End With
        Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
        tbl.TableStyle = "TableStyleMedium2"
        tbl.ShowTotals = False
        xlWS.Cells.EntireColumn.AutoFit
    
    End With
     
    xlWb.Save
 
    If Not bOpen Then
        xlApp.Workbooks.Close
        Set xlApp = Nothing
    Else
        xlApp.ActiveWindow.WindowState = xlMaximized
    End If
 
 
    On Error GoTo 0
    Exit Sub

XLFormatTable_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XLFormatTable, line " & Erl & "."

End Sub
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
I use this as part of a routine that will either open a query or export it and format it as a table.

Call it using the Query name as a string, and a save name.
Save it all in a module (mod_ExcelExport?)

The second function is a pretty direct answer to your question.
SQL:
Option Compare Database
Option Explicit


Const xlLandscape    As Long = 2
Const xlCenter       As Long = -4108
Const xlBottom       As Long = -4107
Const xlContext      As Integer = -5002
Const xlDown         As Integer = -4121
Const xlContinuous   As Integer = 1
Const xlThin         As Integer = 2
Const xlLastCell     As Long = 11
Const xlYes          As Long = 1
Const xlSrcRange     As Long = 1
Const xlMaximized    As Integer = -4137   ' Maximized
Const xlMinimized    As Integer = -4140   ' Minimized
Const xlNormal       As Integer = -4143   ' Normal
Public bOverWrite    As Boolean
Public bOpenFile     As Boolean
Global glDb As DAO.Database

'Report handling all queries / report selecting moved to one module for simplicity

Public Sub ListReporter(qryName As String, qrySaveName As String, XLExport As Integer)

    Dim txtQueryName     As String
    Dim strSaveFile      As String
    Dim sSql             As String
    Dim sComputerName    As String
    Dim iResp            As Integer
    Dim sRange           As String
    Dim sUser            As String

    On Error GoTo ListReporter_Error
    bOpenFile = True
    If glDb Is Nothing Then Set glDb = CurrentDb

    txtQueryName = Left(Replace(qryName, " ", "_"), 30)  'Remove any spaces as spaces in the sheet name cause issues.

    strSaveFile = (CurrentApplication.Path & "\" & qrySaveName & "_" & Format(Date, "yyyymmdd")) & ".xlsx"


    If Not XLExport Then
        DoCmd.OpenQuery qryName, acViewNormal, acReadOnly
    Else

        If IsFileOpen(strSaveFile) Then
            MsgBox "The file " & strSaveFile & " is currently open." & vbCrLf & "Please close it before trying to overwrite it!!", vbInformation, "File Open!"
            Exit Sub
        End If
    
        If FileExists(strSaveFile) Then
            If bOverWrite Then
                Kill strSaveFile
            Else
                iResp = MsgBox("This file is already saved, do you want to delete it first? " & vbCrLf & _
                    "Selecting no will retain any formatting, but may result in an error if you have any summary or total fields added to the existing version", vbYesNo, "File Exists!")
                If iResp = vbYes Then
                    Kill strSaveFile
                End If
            End If
        End If
    
        sRange = txtQueryName
        DoCmd.TransferSpreadsheet acExport, 10, qryName, strSaveFile, True, sRange, True
    
        'Debug.Print "here1"
        If Not bOpenFile Then
            Call XLFormatTable(strSaveFile, txtQueryName, False)
        Else
            If MsgBox("Your file has been saved in the c:\ExcelSaves folder, do you want to open it ?", vbYesNo, "Reports") = vbYes Then
                Call XLFormatTable(strSaveFile, txtQueryName, True)
            Else
                Call XLFormatTable(strSaveFile, txtQueryName, False)
        
            End If
        End If
    
    End If

    On Error GoTo 0
    Exit Sub

ListReporter_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ListReporter of ReportLogger"

End Sub


Public Sub XLFormatTable(sFile As String, sSheet As String, Optional bOpen As Boolean = True)

    On Error GoTo XLFormatTable_Error
    ' Late binding to avoid reference:
    Dim xlApp            As Object        'Excel.Application
    Dim xlWb             As Object        'Workbook
    Dim xlWS             As Object        'Worksheet
    Dim tbl              As Object
    Dim rng              As Object
   
    'Debug.Print sFile, sSheet
   
    ' Create the instance of Excel that we will use to open the temp book
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = bOpen
    Set xlWb = xlApp.Workbooks.Open(sFile)
    'Debug.Print xlWB.Name
    Set xlWS = xlWb.Worksheets(sSheet)

    ' Format our temp sheet
    ' ************************************************** *************************

    xlApp.Range("A1").Select

    With xlWS
        '        With .UsedRange
        '            .borders.LineStyle = xlContinuous
        '            .borders.ColorIndex = 0
        '            .borders.TintAndShade = 0
        '            .borders.Weight = xlThin
        '        End With
        '
        '        'format header 90 degree
        '        With .Range("i1:y1")
        '            .HorizontalAlignment = xlCenter
        '            .VerticalAlignment = xlBottom
        '            .WrapText = False
        '            .Orientation = 90
        '            .AddIndent = False
        '            .IndentLevel = 0
        '            .ShrinkToFit = False
        '            .ReadingOrder = xlContext
        '            .MergeCells = False
        '        End With
        '        .UsedRange.Rows.RowHeight = 15
        '        .UsedRange.Columns.AutoFit

        With xlWb.Sheets(sSheet)
            Set rng = .Cells(1, 1).CurrentRegion
        End With
        Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
        tbl.TableStyle = "TableStyleMedium2"
        tbl.ShowTotals = False
        xlWS.Cells.EntireColumn.AutoFit
   
    End With
    
    xlWb.Save

    If Not bOpen Then
        xlApp.Workbooks.Close
        Set xlApp = Nothing
    Else
        xlApp.ActiveWindow.WindowState = xlMaximized
    End If


    On Error GoTo 0
    Exit Sub

XLFormatTable_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XLFormatTable, line " & Erl & "."

End Sub
Hi,

Thanks for this,

I've been googling but i have no idea how to call this correctly.

But i plan to run through those tutorials so hopefully it will help because i would love to be able to read the code you posted properly
 

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
Let's assume you have a query called qry_Report_output and you want the report call Big_Report_2021_03_19
Somewhere on a form on a button click for instance use the code like this.

Code:
Dim sRepName as String

sRepName = "Big_Report_" & Format(Date(),"yyyy_mm_dd")

Call ListReporter("qpt_Report_Output", sRepName, True)
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
Let's assume you have a query called qry_Report_output and you want the report call Big_Report_2021_03_19
Somewhere on a form on a button click for instance use the code like this.

Code:
Dim sRepName as String

sRepName = "Big_Report_" & Format(Date(),"yyyy_mm_dd")

Call ListReporter("qpt_Report_Output", sRepName, True)
thats brilliant thanks, im going to give it a whirl this eve
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
Let's assume you have a query called qry_Report_output and you want the report call Big_Report_2021_03_19
Somewhere on a form on a button click for instance use the code like this.

Code:
Dim sRepName as String

sRepName = "Big_Report_" & Format(Date(),"yyyy_mm_dd")

Call ListReporter("qpt_Report_Output", sRepName, True)
Sorry for the, i've just had the chance to try and run it.

Im getting variable not defined on
Code:
Applicationcurrent.Path" so changed to Application.CurrentProject.path

Sub not defined on
ISFileOpen, FileExists etc.

I tried just cutting it out to see if the export could work but no luck.

As i'm really not sure what i am looking at, and to save your time and frustration, Im happy to try and find documentation and videos to understand this a bit better.

Otherwise im just going to keep asking until someone basically writes it out for me every step of the way (which isnt the idea of course)
 
Last edited:

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
Apologies, I cut and paste that in a bit of a hurry.

The missing bits are other functions - I have included the whole lot in the code below.
It includes the correction to the current path.
Code:
Option Compare Database
Option Explicit
    
Const xlLandscape    As Long = 2
Const xlCenter       As Long = -4108
Const xlBottom       As Long = -4107
Const xlContext      As Integer = -5002
Const xlDown         As Integer = -4121
Const xlContinuous   As Integer = 1
Const xlThin         As Integer = 2
Const xlLastCell     As Long = 11
Const xlYes          As Long = 1
Const xlSrcRange     As Long = 1
Const xlMaximized    As Integer = -4137   ' Maximized
Const xlMinimized    As Integer = -4140   ' Minimized
Const xlNormal       As Integer = -4143   ' Normal
Public bOverWrite    As Boolean
Public bOpenFile     As Boolean
Global glDb As DAO.Database
    
'Report handling all queries / report selecting moved to one module for simplicity

Public Sub ListReporter(qryName As String, qrySaveName As String, XLExport As Integer)

    Dim txtQueryName     As String
    Dim strSaveFile      As String
    Dim sSql             As String
    Dim sComputerName    As String
    Dim iResp            As Integer
    Dim sRange           As String
    Dim sUser            As String
    
    On Error GoTo ListReporter_Error
    bOpenFile = True
    If glDb Is Nothing Then Set glDb = CurrentDb
    
    txtQueryName = Left(Replace(qryName, " ", "_"), 30)  'Remove any spaces as spaces in the sheet name cause issues.
    
    strSaveFile = (Application.CurrentProject.Path & "\" & qrySaveName & "_" & Format(Date, "yyyymmdd")) & ".xlsx"

    If Not XLExport Then
        DoCmd.OpenQuery qryName, acViewNormal, acReadOnly
    Else
  
        If IsFileOpen(strSaveFile) Then
            MsgBox "The file " & strSaveFile & " is currently open." & vbCrLf & "Please close it before trying to overwrite it!!", vbInformation, "File Open!"
            Exit Sub
        End If
        
        If FileExists(strSaveFile) Then
            If bOverWrite Then
                Kill strSaveFile
            Else
                iResp = MsgBox("This file is already saved, do you want to delete it first? " & vbCrLf & _
                    "Selecting no will retain any formatting, but may result in an error if you have any summary or total fields added to the existing version", vbYesNo, "File Exists!")
                If iResp = vbYes Then
                    Kill strSaveFile
                End If
            End If
        End If
        
        sRange = txtQueryName
        DoCmd.TransferSpreadsheet acExport, 10, qryName, strSaveFile, True, sRange, True
        
        'Debug.Print "here1"
        If Not bOpenFile Then
            Call XLFormatTable(strSaveFile, txtQueryName, False)
        Else
            If MsgBox("Your file has been saved in the c:\ExcelSaves folder, do you want to open it ?", vbYesNo, "Reports") = vbYes Then
                Call XLFormatTable(strSaveFile, txtQueryName, True)
            Else
                Call XLFormatTable(strSaveFile, txtQueryName, False)
            
            End If
        End If
        
    End If
    
    On Error GoTo 0
    Exit Sub

ListReporter_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ListReporter of ReportLogger"

End Sub


Public Sub XLFormatTable(sFile As String, sSheet As String, Optional bOpen As Boolean = True)

    On Error GoTo XLFormatTable_Error
    ' Late binding to avoid reference:
    Dim xlApp            As Object        'Excel.Application
    Dim xlWb             As Object        'Workbook
    Dim xlWS             As Object        'Worksheet
    Dim tbl              As Object
    Dim rng              As Object
      
    'Debug.Print sFile, sSheet
      
    ' Create the instance of Excel that we will use to open the temp book
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = bOpen
    Set xlWb = xlApp.Workbooks.Open(sFile)
    'Debug.Print xlWB.Name
    Set xlWS = xlWb.Worksheets(sSheet)

    ' Format our temp sheet
    ' ************************************************** *************************

    xlApp.Range("A1").Select

    With xlWS
        '        With .UsedRange
        '            .borders.LineStyle = xlContinuous
        '            .borders.ColorIndex = 0
        '            .borders.TintAndShade = 0
        '            .borders.Weight = xlThin
        '        End With
        '
        '        'format header 90 degree
        '        With .Range("i1:y1")
        '            .HorizontalAlignment = xlCenter
        '            .VerticalAlignment = xlBottom
        '            .WrapText = False
        '            .Orientation = 90
        '            .AddIndent = False
        '            .IndentLevel = 0
        '            .ShrinkToFit = False
        '            .ReadingOrder = xlContext
        '            .MergeCells = False
        '        End With
        '        .UsedRange.Rows.RowHeight = 15
        '        .UsedRange.Columns.AutoFit

        With xlWb.Sheets(sSheet)
            Set rng = .Cells(1, 1).CurrentRegion
        End With
        Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
        tbl.TableStyle = "TableStyleMedium2"
        tbl.ShowTotals = False
        xlWS.Cells.EntireColumn.AutoFit
      
    End With
        
    xlWb.Save
    
    If Not bOpen Then
        xlApp.Workbooks.Close
        Set xlApp = Nothing
    Else
        xlApp.ActiveWindow.WindowState = xlMaximized
    End If
    
    
    On Error GoTo 0
    Exit Sub

XLFormatTable_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XLFormatTable, line " & Erl & "."

End Sub


Function IsFileOpen(fileName As String)
    Dim filenum As Integer, errnum As Integer

    'Firstly check there is a file to check ;)
    If Not FileExists(fileName) Then
        IsFileOpen = False        'doesn't exist so therefore it can't be open
        Exit Function
    End If

    On Error Resume Next        ' Turn error checking off.
    filenum = FreeFile()        ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open fileName For Input Lock Read As #filenum
    Close filenum        ' Close the file.
    errnum = Err        ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.

    ' Check to see which error occurred.
    Select Case errnum

        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
            IsFileOpen = False

            ' Error number for "Permission Denied."
            ' File is already opened by another user.
        Case 70
            IsFileOpen = True

            ' Another error occurred.
        Case Else
            Error errnum
    End Select

End Function

Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
    'Purpose:   Return True if the file exists, even if it is hidden.
    'Arguments: strFile: File name to look for. Current directory searched if no path included.
    '           bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
    'Note:      Does not look inside subdirectories for the file.
    'Author:    Allen Browne. http://allenbrowne.com June, 2006.
    Dim lngAttributes    As Long

    'Include read-only files, hidden files, system files.
    lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)

    If bFindFolders Then
        lngAttributes = (lngAttributes Or vbDirectory)        'Include folders as well.
    Else
        'Strip any trailing slash, so Dir does not look inside the folder.
        Do While Right$(strFile, 1) = "\"
            strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If

    'If Dir() returns something, the file exists.
    On Error Resume Next
    FileExists = (Len(Dir(strFile, lngAttributes)) > 0)

End Function
 

tucker61

Registered User.
Local time
Today, 03:28
Joined
Jan 13, 2008
Messages
244
I am trying to use the above to format as a table and get the error Invalid Proceedure call or arguement in procedure XLFormatTable, Line 0


Code:
        Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
 

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
At the top of the module I posted there are a number of Constants and Variables set up to enumerate various Excel values.
Make sure you have all of those set up.

(Const xlSrcRange As Long = 1) may be the one you are missing?
 

tucker61

Registered User.
Local time
Today, 03:28
Joined
Jan 13, 2008
Messages
244
At the top of the module I posted there are a number of Constants and Variables set up to enumerate various Excel values.
Make sure you have all of those set up.

(Const xlSrcRange As Long = 1) may be the one you are missing?
you were correct. I will the way you can set to either keep the report open, or closed.

My previous export always made the report Visible and then carried out the formatting.

This seems much smoother.

thanks
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
Apologies, I cut and paste that in a bit of a hurry.

The missing bits are other functions - I have included the whole lot in the code below.
It includes the correction to the current path.
Code:
Option Compare Database
Option Explicit
   
Const xlLandscape    As Long = 2
Const xlCenter       As Long = -4108
Const xlBottom       As Long = -4107
Const xlContext      As Integer = -5002
Const xlDown         As Integer = -4121
Const xlContinuous   As Integer = 1
Const xlThin         As Integer = 2
Const xlLastCell     As Long = 11
Const xlYes          As Long = 1
Const xlSrcRange     As Long = 1
Const xlMaximized    As Integer = -4137   ' Maximized
Const xlMinimized    As Integer = -4140   ' Minimized
Const xlNormal       As Integer = -4143   ' Normal
Public bOverWrite    As Boolean
Public bOpenFile     As Boolean
Global glDb As DAO.Database
   
'Report handling all queries / report selecting moved to one module for simplicity

Public Sub ListReporter(qryName As String, qrySaveName As String, XLExport As Integer)

    Dim txtQueryName     As String
    Dim strSaveFile      As String
    Dim sSql             As String
    Dim sComputerName    As String
    Dim iResp            As Integer
    Dim sRange           As String
    Dim sUser            As String
   
    On Error GoTo ListReporter_Error
    bOpenFile = True
    If glDb Is Nothing Then Set glDb = CurrentDb
   
    txtQueryName = Left(Replace(qryName, " ", "_"), 30)  'Remove any spaces as spaces in the sheet name cause issues.
   
    strSaveFile = (Application.CurrentProject.Path & "\" & qrySaveName & "_" & Format(Date, "yyyymmdd")) & ".xlsx"

    If Not XLExport Then
        DoCmd.OpenQuery qryName, acViewNormal, acReadOnly
    Else
 
        If IsFileOpen(strSaveFile) Then
            MsgBox "The file " & strSaveFile & " is currently open." & vbCrLf & "Please close it before trying to overwrite it!!", vbInformation, "File Open!"
            Exit Sub
        End If
       
        If FileExists(strSaveFile) Then
            If bOverWrite Then
                Kill strSaveFile
            Else
                iResp = MsgBox("This file is already saved, do you want to delete it first? " & vbCrLf & _
                    "Selecting no will retain any formatting, but may result in an error if you have any summary or total fields added to the existing version", vbYesNo, "File Exists!")
                If iResp = vbYes Then
                    Kill strSaveFile
                End If
            End If
        End If
       
        sRange = txtQueryName
        DoCmd.TransferSpreadsheet acExport, 10, qryName, strSaveFile, True, sRange, True
       
        'Debug.Print "here1"
        If Not bOpenFile Then
            Call XLFormatTable(strSaveFile, txtQueryName, False)
        Else
            If MsgBox("Your file has been saved in the c:\ExcelSaves folder, do you want to open it ?", vbYesNo, "Reports") = vbYes Then
                Call XLFormatTable(strSaveFile, txtQueryName, True)
            Else
                Call XLFormatTable(strSaveFile, txtQueryName, False)
           
            End If
        End If
       
    End If
   
    On Error GoTo 0
    Exit Sub

ListReporter_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ListReporter of ReportLogger"

End Sub


Public Sub XLFormatTable(sFile As String, sSheet As String, Optional bOpen As Boolean = True)

    On Error GoTo XLFormatTable_Error
    ' Late binding to avoid reference:
    Dim xlApp            As Object        'Excel.Application
    Dim xlWb             As Object        'Workbook
    Dim xlWS             As Object        'Worksheet
    Dim tbl              As Object
    Dim rng              As Object
     
    'Debug.Print sFile, sSheet
     
    ' Create the instance of Excel that we will use to open the temp book
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = bOpen
    Set xlWb = xlApp.Workbooks.Open(sFile)
    'Debug.Print xlWB.Name
    Set xlWS = xlWb.Worksheets(sSheet)

    ' Format our temp sheet
    ' ************************************************** *************************

    xlApp.Range("A1").Select

    With xlWS
        '        With .UsedRange
        '            .borders.LineStyle = xlContinuous
        '            .borders.ColorIndex = 0
        '            .borders.TintAndShade = 0
        '            .borders.Weight = xlThin
        '        End With
        '
        '        'format header 90 degree
        '        With .Range("i1:y1")
        '            .HorizontalAlignment = xlCenter
        '            .VerticalAlignment = xlBottom
        '            .WrapText = False
        '            .Orientation = 90
        '            .AddIndent = False
        '            .IndentLevel = 0
        '            .ShrinkToFit = False
        '            .ReadingOrder = xlContext
        '            .MergeCells = False
        '        End With
        '        .UsedRange.Rows.RowHeight = 15
        '        .UsedRange.Columns.AutoFit

        With xlWb.Sheets(sSheet)
            Set rng = .Cells(1, 1).CurrentRegion
        End With
        Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
        tbl.TableStyle = "TableStyleMedium2"
        tbl.ShowTotals = False
        xlWS.Cells.EntireColumn.AutoFit
     
    End With
       
    xlWb.Save
   
    If Not bOpen Then
        xlApp.Workbooks.Close
        Set xlApp = Nothing
    Else
        xlApp.ActiveWindow.WindowState = xlMaximized
    End If
   
   
    On Error GoTo 0
    Exit Sub

XLFormatTable_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XLFormatTable, line " & Erl & "."

End Sub


Function IsFileOpen(fileName As String)
    Dim filenum As Integer, errnum As Integer

    'Firstly check there is a file to check ;)
    If Not FileExists(fileName) Then
        IsFileOpen = False        'doesn't exist so therefore it can't be open
        Exit Function
    End If

    On Error Resume Next        ' Turn error checking off.
    filenum = FreeFile()        ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open fileName For Input Lock Read As #filenum
    Close filenum        ' Close the file.
    errnum = Err        ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.

    ' Check to see which error occurred.
    Select Case errnum

        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
            IsFileOpen = False

            ' Error number for "Permission Denied."
            ' File is already opened by another user.
        Case 70
            IsFileOpen = True

            ' Another error occurred.
        Case Else
            Error errnum
    End Select

End Function

Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
    'Purpose:   Return True if the file exists, even if it is hidden.
    'Arguments: strFile: File name to look for. Current directory searched if no path included.
    '           bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
    'Note:      Does not look inside subdirectories for the file.
    'Author:    Allen Browne. http://allenbrowne.com June, 2006.
    Dim lngAttributes    As Long

    'Include read-only files, hidden files, system files.
    lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)

    If bFindFolders Then
        lngAttributes = (lngAttributes Or vbDirectory)        'Include folders as well.
    Else
        'Strip any trailing slash, so Dir does not look inside the folder.
        Do While Right$(strFile, 1) = "\"
            strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If

    'If Dir() returns something, the file exists.
    On Error Resume Next
    FileExists = (Len(Dir(strFile, lngAttributes)) > 0)

End Function
Thanks Minty, i will give it another try in the morning
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
Its worked Minty!

I was getting a "Cannot define field more than once Error[3191]

After googling a bit it turned out it was the underscore in my field names... which sadly i have a lot of but just by simply changing the field name in the query has sorted it.

1616490798576.png


When i get the chance I'm going to go through those youtube tutorials and see what other formatting i can apply

Thanks so much
 
Last edited:

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
That's strange, underscores don't cause a problem, I use them quite a lot in exported queries (I just checked one - Payroll_Name for instance).
That sounds more like a duplicate field name error.

Anyway glad you have it working.
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
That's strange, underscores don't cause a problem, I use them quite a lot in exported queries (I just checked one - Payroll_Name for instance).
That sounds more like a duplicate field name error.

Anyway glad you have it working.
you know i bet you're absolutely right, now that you mention it i did have all fields in the query "*" and then added one again to filter.
IT was just coincidence that as i changed the field name i also reduced the query columns which would have removed the duplicate field
 

tucker61

Registered User.
Local time
Today, 03:28
Joined
Jan 13, 2008
Messages
244
Hi all, i have used the above to format my data as a table, but i have 1 column that i want to format as a Currency - Can this be done in the same procedure ?
 

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
If you format it as currency in the query it might stick.
The more you use them the more you will realise that Excel and Access don't always play nice with each other.

If not you can always add something like (AirCode not tested)

xlWS.Range("E:E").NumberFormat = "£#,##0.00"

to the code where "E:E" is your column
 

Jordonjd

Member
Local time
Today, 12:28
Joined
Jun 18, 2020
Messages
64
I managed to copy the "ListReporter" to make "ListReporterAdd"

I amended the If statements under "If FileExists" section to exit the sub if the file does not exist,
So now i have two functions i can call:

1- To export, create and format to the new excel file
2- To export, create and format to a new sheet on the existing excel file

So i can have the weekly repair status on the first sheet and weekly shipped report on the second sheet

I also added "exfilepath"

Code:
Public Sub ListReporteradd(qryName As String, qrySaveName As String, ExFilepath As String, XLExport As Integer)

I'm not sure if its done properly but i'm playing around, it seems to allow me to use a dynamic file path that i can populate from a dlookup on my form

This all exceeds my expectations already but once i am done with the Youtube tutorials on merging cells and fonts etc

I should have a really professional weekly report that can be generated and attached to an email in a click of a few buttons.


Thank you very much again
 

Minty

AWF VIP
Local time
Today, 11:28
Joined
Jul 26, 2013
Messages
8,619
Excellent - It sounds as if you have achieved your end goal and far more importantly learned by experimenting a bit.
This is so much better than simply "cut and paste and it works".

By enhancing your own knowledge next time you need to do something you will be in a position to use the existing "stuff" and expand on it.

In 20 ish years of doing this on and off, I still google and learn pretty much every day. Sometimes it's just a better method, sometimes it's a genuinely new thing I just didn't know.
 

Users who are viewing this thread

Top Bottom