Modifying text formatting in 1 column on Export from Access to Excel (1 Viewer)

Cark · Apr 19, 2017

I am wanting to modify the text formatting of a column when it is exported from my Access database so that the text is BOLD and in ITALICS.

The column will not change in terms of its position in my Excel spreadsheet. It will always be Column D.

The code I am using to spit out my Access data into Excel is as follows:

Code:

    Me.All_Fleet_Chk.Value = True
    
    Dim ctl As Control
    Dim sFilter As String
    Dim sContName As String

    sFilter = ""
    sFilter = "AND TblTcDel.[ATA2DIGIT] IN (0"
    For Each ctl In Controls

        If ctl.Tag = "ATA" Then
            sContName = Right(ctl.Name, 2)
            'Debug.Print sContName
              'Once you have this working listing each control now interrogate the value
            If ctl.Value = True Then
                sFilter = sFilter & "," & sContName
            End If
        End If
    Next ctl
    sFilter = sFilter & ")"
    Debug.Print sFilter

    Dim dbsCurrent      As Database
    Dim SQL_Name        As QueryDef
    Dim SQL_Output      As String
    Dim dStart          As String
    Dim dEnd            As String

    Set dbsCurrent = CurrentDb
    Set SQL_Name = dbsCurrent.QueryDefs("qry_report_criteria")

    dStart = "#" & Format([Forms]![FrmRptCriteria]![Beg_date_txt], "mm/dd/yyyy") & "#"
    dEnd = "#" & Format([Forms]![FrmRptCriteria]![End_Date_txt], "mm/dd/yyyy") & "#"


    SQL_Output = "SELECT TblTcDel.ID, TblTcDel.Date, tblfltcodes.FlightCode, TblTcDel.[FLIGHT NO], TblTcDel.STN, TblTcDel.REG, TblTcDel.ATA, TblTcDel.ATASecondary, TblTcDel.[REASON FOR DELAY], TblTcDel.[DELAY HRS], TblTcDel.[DELAY MINS], TblTcDel.AOG, TblTcDel.[Part Number], TblTcDel.[Serial Number], TblTcDel.[Rectification Information], TblTcDel.DelayTotalMins, tblactype.actypeid, tblactype.Type, tblactype.Manufacturer, tblflighttype.flighttypeid, TblTcDel.[Severity Index], TblTcDel.[Charter Flight] " & _
                 "FROM tblactype INNER JOIN (tblflighttype INNER JOIN (TblAcrft INNER JOIN ((TblTcDel INNER JOIN TblAirports ON TblTcDel.STN = TblAirports.STN) INNER JOIN tblfltcodes ON TblTcDel.Flight_Code = tblfltcodes.fltcodeid) ON TblAcrft.Reg = TblTcDel.REG) ON tblflighttype.flighttypeid = tblfltcodes.LinktoFlightType) ON tblactype.actypeid = TblAcrft.ModelLink " & _
                 "WHERE ((TblTcDel.Date)>=" & dStart & " And (TblTcDel.Date)<=" & dEnd & " AND ((TblTcDel.DelayTotalMins)>=[forms]![FrmRptCriteria]![Delay_Time])) "

    If Me.All_Fleet_Chk = True Then
        If Me.All_Type_Chk = True Then         ' All Fleets all Flights
            sWhere = ""
        Else                                   ' All Fleets limited to Flight type as chosen
            sWhere = " AND ((tblflighttype.flighttypeid)=[forms]![FrmRptCriteria]![Type_cbo]) "
        End If
    Else
        If Me.NewACRFTchk = True Then
            If Me.All_Type_Chk = True Then
            sWhere = " AND ((TblAcrft.New)=-1) "
            Else
            sWhere = " AND ((TblAcrft.New)=-1) AND ((tblflighttype.flighttypeid)=[forms]![FrmRptCriteria]![Type_cbo]) "
            End If
        Else
            If Me.All_Type_Chk = True Then         ' Selected fleet all flights
                If Me.ETOPSChk = True Then
                    sWhere = " AND ((TblAcrft.ETOPS)=-1) "
                Else
                    If Not IsNull(Me.REGFilter) Then
                        sWhere = " AND TblTcDel.[REG] = [Forms]![FrmRptCriteria]![REGFilter] "
                    Else
                        sWhere = " AND ((tblactype.actypeid)=[Forms]![FrmRptCriteria]![Model_cbo]) "
                    End If
                End If
            Else                                   ' Selected Fleet Selected Flight Type
                If Me.ETOPSChk = True Then
                    sWhere = " AND ((TblAcrft.ETOPS)=-1) AND ((tblflighttype.flighttypeid)=[forms]![FrmRptCriteria]![Type_cbo]) "
                Else
                    If Not IsNull(Me.REGFilter) Then
                        sWhere = " AND TblTcDel.[REG] = [Forms]![FrmRptCriteria]![REGFilter] AND ((tblflighttype.flighttypeid)=[forms]![FrmRptCriteria]![Type_cbo]) "
                    Else
                        sWhere = " AND ((tblactype.actypeid)=[Forms]![FrmRptCriteria]![Model_cbo]) AND ((tblflighttype.flighttypeid)=[forms]![FrmRptCriteria]![Type_cbo]) "
                    End If
                End If
            End If
        End If
    End If
    If Not IsNull(Me.EventTypeFilter) Then
        sWhere = sWhere & " AND ((TblTcDel.[Event Type])=[Forms]![FrmRptCriteria]![EventTypeFilter])"
    End If
    If Me.SummerChk.Value = True Then
        sWhere = sWhere & " AND ((TblTcDel.[Season])= 'Summer') "
    End If
    If Me.WinterChk.Value = True Then
        sWhere = sWhere & " AND ((TblTcDel.[Season])= 'Winter') "
    End If
    If Me.Code41Chk.Value = True Then
        sWhere = sWhere & " AND ((TblTcDel.[Delay Type])= '41') "
    End If
    If Me.Code46Chk.Value = True Then
        sWhere = sWhere & " AND ((TblTcDel.[Delay Type])= '46') "
    End If
    If Me.ETOPSSectorChk.Value = True Then
        sWhere = " AND ((TblTcDel.[ETOPS Sector])=-1) "
    End If
    If Me.CharterFlightChk.Value = True Then
        sWhere = sWhere & " AND ((TblTcDel.[Charter Flight])=-1) "
    End If
    
    If Not IsNull(Me.SeverityIndexLower) And IsNull(Me.SeverityIndexUpper) Then
        sWhere = sWhere & " AND ((TblTcDel.[Severity Index])>=[Forms]![FrmRptCriteria]![SeverityIndexLower])"
    End If
    If Not IsNull(Me.SeverityIndexLower) And Not IsNull(Me.SeverityIndexUpper) Then
        sWhere = sWhere & " AND ((TblTcDel.[Severity Index])>=[Forms]![FrmRptCriteria]![SeverityIndexLower]) AND ((TblTcDel.[Severity Index])<=[Forms]![FrmRptCriteria]![SeverityIndexUpper])"
    End If
    If IsNull(Me.SeverityIndexLower) And Not IsNull(Me.SeverityIndexUpper) Then
        sWhere = sWhere & " AND ((TblTcDel.[Severity Index])<=[Forms]![FrmRptCriteria]![SeverityIndexUpper])"
    End If
    If Me.SeverityFilter = "High" Then
        sWhere = sWhere & " AND ((TblTcDel.[Severity Index])>=0.75)"
    End If
    If Me.SeverityFilter = "Medium" Then
        sWhere = sWhere & " AND ((TblTcDel.[Severity Index])>=0.27) AND ((TblTcDel.[Severity Index])<0.75)"
    End If
    If Me.SeverityFilter = "Low" Then
        sWhere = sWhere & " AND ((TblTcDel.[Severity Index])<0.27)"
    End If
    
    sWhere = sWhere & " AND ((tblactype.actypeid)=2) "

    Debug.Print SQL_Output & sWhere & sFilter
    SQL_Name.SQL = SQL_Output & sWhere & sFilter
    
    DoCmd.Echo False
    DoCmd.OpenQuery "Top10Issues737300Cut"
    DoCmd.RunCommand acCmdOutputToExcel
    DoCmd.Close acQuery, "Top10Issues737300Cut"
    DoCmd.Echo True
    
    Set dbsCurrent = Nothing
    Set SQL_Name = Nothing

How would I add a little extra to the end, in order to make TblTcDel.[REG] appear with Bold and italics? Ideally I would like the column header to not be touched so maybe doing something like D2 through to the end might be the best solution?

I look forward to hearing you clever Access guys' opinions

sxschech · Apr 19, 2017

You could use excel automation to format the col after the data have been exported. Here is an example that will make col D be bold and italic.

Code:

Sub FormatExcel(FileName As String)
'Format excel file 
'20150531
'http://www.ozgrid.com/forum/showthread.php?t=17608
'http://www.accessibledatasolutions.com/articles11/AccessToExcel.htm

    Set objapp = CreateObject("Excel.Application")
    objapp.Visible = True
    Set wb = objapp.workbooks.Open(FileName, True, False)
    'select all worksheets & cells In turn
    For Each ws In wb.worksheets
    With WS
        lastrow = .Range("A1").currentregion.rows.Count
            lastCol = .Range("A1").currentregion.Columns.Count
        .Columns("D").Font.Bold = True
        .Columns("D").Font.Italic = True
                
        End With
    Next 'next worksheet
 objapp.sheets(1).Activate
    wb.Save
    objapp.Quit
    Set objapp = Nothing
end sub

Cark · Apr 20, 2017

Thanks for the snippet of code, however I don't fully understand which bits I need to tweak to make it fit my code. I have tried it as you supplied it and it gave me some errors. So obviously I need to tweak it.

My code is exporting 3 Excel spreadsheets at once called:
Top10Issues737300.xlsx, Top10Issues737800.xlsx and Top10Issues757200.xlsx

Is this going to cause the code to throw a wobbler and do we need to relook at it?

sxschech · Apr 20, 2017

The FormatExcel code would go in a standard module, not in the form code. Then, at its simplest, in your form code, after the excel files have been created, call the format code as below:

Code:

call formatexcel("Top10Issues737300.xlsx")
call formatexcel("Top10Issues737800.xlsx")
call formatexcel("Top10Issues757200.xlsx")

Cark · Apr 21, 2017

For some reason when I have the first snippet as a module and then add the call formatexcel line in my form code, it gives me a read-only copy as well.

I have just tried to do 1 spreadsheet at a time (not trying to run before I can walk), but when I export the Top10Issues737300.xlsx, it exports the Top10Issues737300.xlsx + a read-only copy of Top10Issues737300.xlsx in which it formats the column perfectly with the bold and italic text in column D.

The last bit of the form code that I am using is:

Code:

    DoCmd.Echo False
    DoCmd.OpenQuery "Top10Issues737300Cut"
    DoCmd.RunCommand acCmdOutputToExcel
    Call FormatExcel("Top10Issues737300Cut.xlsx")
    DoCmd.Close acQuery, "Top10Issues737300Cut"
    DoCmd.Echo True

And the module code I am using is:

Code:

Option Compare Database

Sub FormatExcel(FileName As String)
'Format excel file
'20150531
'http://www.ozgrid.com/forum/showthread.php?t=17608
'http://www.accessibledatasolutions.com/articles11/AccessToExcel.htm

    Set objapp = CreateObject("Excel.Application")
    objapp.Visible = True
    Set wb = objapp.workbooks.Open(FileName, True, False)
    'select all worksheets & cells In turn
    For Each WS In wb.worksheets
    With WS
        lastrow = .Range("A1").currentregion.rows.Count
            lastCol = .Range("A1").currentregion.Columns.Count
        .Columns("D").Font.Bold = True
        .Columns("D").Font.Italic = True
                
        End With
    Next 'next worksheet
 objapp.sheets(1).Activate
    Set objapp = Nothing
    
End Sub

Is this something to do with the save code? I don't need the spreadsheets to be saved automatically, so I would like to delete those bits of code.

Cark · Apr 21, 2017

And how would I go about setting the sheet cells to Arial? For some reason it seems to be defaulting to Calibri whereas before I was managing to get it to default Arial.

sxschech · Apr 21, 2017

.Columns("D").Font.Name = "Arial"

or for entire spreadsheet

.Columns.Font.Name = "Arial"

sxschech · Apr 22, 2017

Not sure how I missed your earlier message and not sure why you are opening as query than then saving to excel.

Replace:

DoCmd.Echo False
DoCmd.OpenQuery "Top10Issues737300Cut"
DoCmd.RunCommand acCmdOutputToExcel
Call FormatExcel("Top10Issues737300Cut.xlsx")
DoCmd.Close acQuery, "Top10Issues737300Cut"
DoCmd.Echo True

With doing like this:

Code:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Top10Issues737300Cut", "DriveLetter:\Directory\Top10Issues737300Cut.xlsx", True               
Call FormatExcel("DriveLetter:\Directory\Top10Issues737300Cut.xlsx")

Then repeat those lines for the other files substituting their name and location.

Drive letter directory would be replaced something like this:
C:\OutputFiles\Top10Issues737300Cut.xls

Cark · Apr 24, 2017

And what would I do if I didn't want to save the file under a set filename? Could I just omit it? I am wanting it so that the user can change the filename to whatever they want when they save it and can also choose their own location.

sxschech · Apr 25, 2017

When I return to work, I can give you some code that will prompt for a file name and allow user to choose where to save the file. That was how the code was originally set up, but I deleted that in my post because I thought you had specific file name/location. Sorry about the misunderstanding.

Cark · Apr 25, 2017

Sweet that would be really appreciated. Although for this little bit of the project I am not wanting the user to be prompted where to save the file (I'd like them just to be able to see the Excel file and then to do with it what they will), I will be needing that snippet of code for something further down the line.

Thanks, I hope to look through the bit of code as soon as possible to you sending it. I'd really appreciate it if you could point out the exact bits I would need to edit so that I could assimilate the information. I'm still very much at the stage where I'm learning about code via tweaking the building blocks and then seeing the effects rather than knowing what each bit does/means.

sxschech · Apr 25, 2017

I copied some code and modified it, so may need further adjustments to work in your situation. I included code to test if file exists and prompt user to replace. If you don't need to worry about that, you can remove it. Since you have multiple files, you will either need to set up a loop or break the save or replace out into another code block so that you are not repeating things three times. Parts in red are optional. Bold should be changed to your values. Default is if you want to display a default value, the example shows a file name of Default plus the date: DEFAULT_20170425. If you don't need a default, you can delete that part. TABNAME is where you can give the spreadsheet tab a specific name. If you don't need that, you can delete that part.

Code:

   Dim FNameExists As Boolean
    Dim stFileName As String
    Dim stExportPath As String
    Dim stExportFileName As String
    On Error Resume Next


     FNameExists = False
FNAME:
    Do While FNameExists = False
        stFileName = InputBox("Enter Name for this excel file.  On the next screen, choose the folder location " & _
                              "for where you want to save the file.", "[B]TITLE[/B]", "[COLOR=Red]DEFAULT_" &  Format(Date, "YYYYMMDD")[/COLOR])
        stFileName = Replace(stFileName, "-", "_")
        If stFileName = "" Then
            MsgBox "No name was chosen, or action was cancelled by user.", vbOKOnly, "Missing Excel File Name"
            GoTo ExitSub
        Else
            stExportPath = selectFolder()
            stExportFileName = stExportPath & "\" & stFileName & ".xlsx"
SaveOrReplace:
            If Dir(stExportFileName) = "" Then
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Top10Issues737300Cut", stExportFileName, True, [COLOR=Red]TABNAME[/COLOR]               
                Call FormatExcel(stExportFileName)                          
                FNameExists = True
            Else
                yesno = MsgBox("File " & stExportFileName & " already exists.  " & vbCrLf & vbCrLf & "Would you like to REPLACE this file?", vbYesNo + vbQuestion, "File Exists")
                If yesno = vbYes Then
                    kill stExportFileName
                    GoTo SaveOrReplace
                Else
                    GoTo FNAME
                End If
            End If
        End If
        Loop
        .MoveNext
    Wend
End If

ExitSub:
Exit Sub
End Sub

Code below would go in a standard module, if you don't already have it. This is used for allowing user to choose the Folder location:

Code:

Function selectFile(filetype As String)
'--------------------------------------------------
' File Browse Code
'--------------------------------------------------
'NOTE: To use this code, you must reference
'The Microsoft Office 14.0 (or current version)
'Object Library by clicking menu Tools>References
'Check the box for:
'Microsoft Office 14.0 Object Library in Access 2010
'Microsoft Office 15.0 Object Library in Access 2013
'Click OK
'http://www.ntechcomm.com/2013/08/select-a-file-with-file-dialog-in-ms-access-with-vba/
'--------------------------------------------------

    Dim fd As office.FileDialog, FileName As String
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'disable multiselect for one file selection
    fd.AllowMultiSelect = False
    fd.Filters.Clear
    If filetype = "Excel" Then
        fd.Filters.Add "Excel or Text Files", "*.xls;*.xlsx;*.xlsm;*.csv;*.txt", 1
    Else
        fd.Filters.Add "Access Files", "*.mdb;*.accdb", 1
    End If
    If fd.Show = True Then
        FileName = fd.SelectedItems(1)
    End If
     
    'clear file dialog
    Set fd = Nothing
    'Return File name and path
    selectFile = FileName
End Function

Function selectFolder()
'--------------------------------------------------
' File Browse Code and pick a folder
'--------------------------------------------------
'NOTE: To use this code, you must reference
'The Microsoft Office 14.0 (or current version)
'Object Library by clicking menu Tools>References
'Check the box for:
'Microsoft Office 14.0 Object Library in Access 2010
'Microsoft Office 15.0 Object Library in Access 2013
'Click OK
'http://answers.microsoft.com/en-us/office/forum/office_2003-customize/vba-example-select-a-directory/f1c57e80-8185-48de-8c03-8bc52770a44e
'modified to style of Function selectFile
'--------------------------------------------------
    Dim fd As FileDialog, FolderName As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.AllowMultiSelect = False
    fd.Title = "Choose a Folder"
    If fd.Show = True Then
        FolderName = fd.SelectedItems(1)
    End If
    
    'clear file dialog
    Set fd = Nothing
    'Return Folder name and path
    selectFolder = FolderName
End Function

Cark · Apr 27, 2017

I have a query which I have set up (which pulls some information from a previous query) and I want to export it into Excel. I do not want the user to choose where to save it. I just want it to open up an instance of Excel with the data in it, and from that point the user can do what they want with it. I know most people want to choose a location, but please bear with this constraint just a bit.

The query I am wanting to export, seems to be working perfectly and when I add a new record into the database, the record filters through into the end query that I am wanting to export.

However, when it comes to clicking on the export button on my reporting form, I cannot get the new records to export. It seems as though as soon as I have run the export once using the end query, it cannot be rerun. I know this isn't the case, but this is what seems to be happening in layman's terms and I am a layman.

The relevant pieces of code that I am using are:

Code:

Sub FormatExcelTop10ATAExport(FileName As String)
'Format excel file
'20150531
'http://www.ozgrid.com/forum/showthread.php?t=17608
'http://www.accessibledatasolutions.com/articles11/AccessToExcel.htm

    Set objApp = CreateObject("Excel.Application")
    objApp.Visible = True
    Set wb = objApp.workbooks.Open(FileName, True, False)
    'select all worksheets & cells In turn
    For Each WS In wb.worksheets
    With WS
            .Cells.Font.Name = "Arial"
            lastrow = .Range("A1").currentregion.Rows.Count
            lastCol = .Range("A1").currentregion.Columns.Count
        .Columns("C").Font.Bold = True
        .Columns("C").Font.Italic = True
        .Columns("F").Font.Italic = True
        .Rows(1).Font.Bold = True
        .Rows(1).Font.Italic = False

    End With
    
    Next 'next worksheet
 objApp.sheets(1).Activate
    Set objApp = Nothing
    
End Sub

Code:

    Dim dbsCurrent      As Database
    Dim SQL_Name        As QueryDef
    Dim SQL_Output      As String
    Dim dStart          As String
    Dim dEnd            As String


    Set dbsCurrent = CurrentDb
    Set SQL_Name = dbsCurrent.QueryDefs("Top102DigitForBiMonthly737300")
    
    SQL_Output = "SELECT TblTcDel.ATA2DIGIT, TblTcDel.Date, TblTcDel.REG, TblTcDel.DelayTime, TblTcDel.[REASON FOR DELAY], TblTcDel.[Rectification Information] " & _
                 "FROM TblAcrft INNER JOIN (TblTcDel INNER JOIN Top102DigitForBiMonthly737300Count ON TblTcDel.ATA2DIGIT = Top102DigitForBiMonthly737300Count.ATA2DIGIT) ON TblAcrft.Reg = TblTcDel.REG " & _
                 "WHERE (((TblTcDel.Date)>=[Forms]![FrmRptCriteria]![Beg_Date_Txt] And (TblTcDel.Date)<=[Forms]![FrmRptCriteria]![End_Date_txt]) AND ((TblAcrft.ModelLink)=2)); "

    Debug.Print SQL_Output
    SQL_Name.SQL = SQL_Output
    
    DoCmd.Echo False
    DoCmd.OpenQuery "Top102DigitForBiMonthly737300"
    Call FormatExcelTop10ATAExport("Top102DigitForBiMonthly737300.xlsx")
    DoCmd.Close acQuery, "Top102DigitForBiMonthly737300"
    DoCmd.Echo True
        
    Set dbsCurrent = Nothing
    Set SQL_Name = Nothing

I must add a disclaimer that I have thrown this code together by taking snippets from all over the place that I have found inside my database that a previous designer used in addition to bits from the internet. If you are able to trim it down, that would be appreciated.

The formatting of the export is correct and the Excel files are opening just as I want them to, the only issue is that the data that is exported, doesn't seem to match the query Top102DigitForBiMonthly737300.

sxschech · Apr 27, 2017

You may be running into other issues if you are updating data, using your method. Have you tried the TransferSpreadsheet instead of openquery as I suggested in post #8? First do the transferspreadsheet and since as you say, user is not choosing where to save, just pick a location and hard code that into the statement. After that, the user can do a save as of the excel file to put it somewhere else of their choosing if need be.

Cark · Apr 28, 2017

I had a brief play around with it, but because of the fact that it requires (at least as far as I am aware) a specified file path, I shied away from it as ideally I don't want a saved file to be produced (I know a very awkward design demand haha).

From looking at your transferspreadsheet post, it doesn't look like I will need to add anything extra is there?

Modifying text formatting in 1 column on Export from Access to Excel (1 Viewer)

Cark

Registered User.

sxschech

Registered User.

Cark

Registered User.

sxschech

Registered User.

Cark

Registered User.

Cark

Registered User.

sxschech

Registered User.

sxschech

Registered User.

Cark

Registered User.

sxschech

Registered User.

Cark

Registered User.

sxschech

Registered User.

Cark

Registered User.

sxschech

Registered User.

Cark

Registered User.

Similar threads

Users who are viewing this thread