Export to Excel with Conditional Formatting (1 Viewer)

P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
Please don't flame me for this but I have been reading and trying different code combinations for 2 days and I am about as close as I can get without asking someone to help me with the remaining code to finish this off. I don't have any hair left to pull out as I can't seem to know enough to edit the codes I have found.

ok... I have a bunch of queries I made and a form with buttons using macros to export data to excel with formatting and they work great individually. Too many buttons. I then embarked on the journey to combine all of this to one button using Vb code to run the individual queries and make one excel file with multiple sheets.

Once again this works. However... there is always a however isn't there... my OCD alarm keeps going off because my simple VB code does not export with formatting and the sheets look like crap without auto resize, headers color etc.

I am needing the output file to output to the workbook preserving the original formatting and then perform conditional formatting in the Excel sheets on column F that checks to see if the date is 14 days old or older and if so fill the cell red, if not no cell color. I know how to do the conditional formatting in the Excel file but since my code only creates a new file with no formatting I assume I need to use a template and just overwrite the data that goes into the individual sheets each time I click the button on my form to generate the export but I don't know how to code that and everything I have tried isn't working.

I have tried and tried but I just keep failing to accomplish this.

Below is my simple code... will someone please add in the code it needs to make this all happen? Please please please?

Code: 
Private Sub Command35_Click()

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report.xlsx", True, "WanvogWaitVis"

End Sub
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
I am still working on this. I have changed my code to this so I can have the date in the filename.

Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"

End Sub
 
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
okey, first put this in a Module:

Code: 
Function fnLastRow(sh As Worksheet)
    On Error Resume Next
    fnLastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

then, back to your code.
you need to manually put the Format Conditions
to each worksheets in your Excel file.
paste the code, after you export your report,
but Before the END SUB:

Code: 
    Dim xlWB As Object
    Dim xlObj As Object
    Dim xlSheet As Object
    Dim lngRow As Long
    
    Set xlObj = CreateObject("Excel.Application")
    '*************************************************************
    '* replace d:\book11.xlsx with the correct Excel file that
    '* you have
    '*
    '*************************************************************
    Set xlWB = xlObj.Workbooks.Open("d:\book11.xlsx", False, False)  'replace the Excel file here!!!
    
    For Each xlSheet In xlWB.WorkSheets
        
        With xlSheet
            
            
            lngRow = fnLastRow(xlSheet)
            Debug.Print lngRow
            
            .Range("F1:F" & lngRow).Select
            xlObj.Selection.FormatConditions.Add Type:=2, Formula1:= _
                    "=TODAY()-F1<13"
            xlObj.Selection.FormatConditions(xlObj.Selection.FormatConditions.Count).SetFirstPriority
            With xlObj.Selection.FormatConditions(1).Interior
                .PatternColorIndex = -4105
                .Color = 255
                .TintAndShade = 0
            End With
            xlObj.Selection.FormatConditions(1).StopIfTrue = False
            
        End With

    Next
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
OK... I created the module as you instructed. I saved it as "ExportFormatting".

I put the code you showed in my file like this:
Code: 
Option Compare Database
Private Sub Command35_Click()

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"

Dim xlWB As Object
    Dim xlObj As Object
    Dim xlSheet As Object
    Dim lngRow As Long
    
    Set xlObj = CreateObject("Excel.Application")
    '*************************************************************
    '* replace d:\book11.xlsx with the correct Excel file that
    '* you have
    '*
    '*************************************************************
    Set xlWB = xlObj.Workbooks.Open("W:\Quality-Projects\RCabler\Databases\Weekly Reports\Templates\Waiting on Visual Weekly Report.xlsx", False, False)  'replace the Excel file here!!!
    
    For Each xlSheet In xlWB.WorkSheets
        
        With xlSheet
            
            
            lngRow = fnLastRow(xlSheet)
            Debug.Print lngRow
            
            .Range("F1:F" & lngRow).Select
            xlObj.Selection.FormatConditions.Add Type:=2, Formula1:= _
                    "=TODAY()-F1<13"
            xlObj.Selection.FormatConditions(xlObj.Selection.FormatConditions.Count).SetFirstPriority
            With xlObj.Selection.FormatConditions(1).Interior
                .PatternColorIndex = -4105
                .Color = 255
                .TintAndShade = 0
            End With
            xlObj.Selection.FormatConditions(1).StopIfTrue = False
            
        End With

    Next
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing

End Sub

But when I click the button I get an error stating "Compile error: User-defined type not defined" and it highlights the first line in the module.

I apologize I am not very good at this. I usually have someone that helps me with this code but he is unavailable.
 
Last edited:
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
you remove those asterisks.
it belongs to the group of asterisk
above, which is a comment line.
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
I removed all of this:
Code: 
'*************************************************************
    '* replace d:\book11.xlsx with the correct Excel file that
    '* you have
    '*
    '*************************************************************

but I still get the same error
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
Code now looks like this:
Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"

Dim xlWB As Object
    Dim xlObj As Object
    Dim xlSheet As Object
    Dim lngRow As Long
    
    Set xlObj = CreateObject("Excel.Application")
    
    Set xlWB = xlObj.Workbooks.Open("W:\Quality-Projects\RCabler\Databases\Weekly Reports\Templates\Waiting on Visual Weekly Report.xlsx", False, False)  'replace the Excel file here!!!
    
    For Each xlSheet In xlWB.WorkSheets
        
        With xlSheet
            
            
            lngRow = fnLastRow(xlSheet)
            Debug.Print lngRow
            
            .Range("F1:F" & lngRow).Select
            xlObj.Selection.FormatConditions.Add Type:=2, Formula1:= _
                    "=TODAY()-F1<13"
            xlObj.Selection.FormatConditions(xlObj.Selection.FormatConditions.Count).SetFirstPriority
            With xlObj.Selection.FormatConditions(1).Interior
                .PatternColorIndex = -4105
                .Color = 255
                .TintAndShade = 0
            End With
            xlObj.Selection.FormatConditions(1).StopIfTrue = False
            
        End With

Next
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing

End Sub
 
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
ok, go to debug mode.
stop the code first if it is running.

on your command9_click event on VBE, press F9 on
any line.
go back to your form and click the button again.
this will take you to debug mode.
press F8 to trace through the code.
write down the line where error occured.
post the faulty line of code.
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
arnelgp said:
ok, go to debug mode.
stop the code first if it is running.

on your command9_click event on VBE, press F9 on
any line.
go back to your form and click the button again.
this will take you to debug mode.
press F8 to trace through the code.
write down the line where error occured.
post the faulty line of code.
Click to expand...

As I said earlier... the error occurs and highlights the first line of the code you gave me to create the module (using Access 2013 if that matters):

Code: 
Function fnLastRow(sh As Worksheet)
 

Attachments

  • error2.jpg
    error2.jpg
    86 KB · Views: 185
Last edited:
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
replace the code with this one:

Code: 
Public Function fnLastRow(sh As Object)
On Error Resume Next
            fnLastRow = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=2, _
                                LookIn:=5, _
                                SearchOrder:=1, _
                                SearchDirection:=2, _
                                MatchCase:=False).row

End Function
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
I did as you instructed and I received another error. The code did run the export and create the file but did not preserve table formatting and did not contain the conditional formatting. The error I received was "Compile error: Invalid or unqualified reference".

I attached a screenshot of where the error highlighted. It highlighted the .Range

Question... is this code having me specify a template file? I thought it was and I have the path to a template file specified here:
Code: 
Set xlObj = CreateObject("Excel.Application")
    
    Set xlWB = xlObj.Workbooks.Open("W:\Quality-Projects\RCabler\Databases\Weekly Reports\Templates\Waiting on Visual Weekly Report.xlsx", False, False)  'replace the Excel file here!!!
    
    For Each xlSheet In xlWB.WorkSheets

If that is incorrect please let me know so I can correct any mistakes
 

Attachments

  • error.jpg
    error.jpg
    78.7 KB · Views: 260
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
Attached is a screenshot of what the excel file should look like after output
 

Attachments

  • screen.JPG
    screen.JPG
    88.7 KB · Views: 205
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
no its not based on the template.
after you export an Excel file is
created, right (strFileName).

use (strFileName) and open this one:

...Worbooks.Open(strFileName, False, False)
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
arnelgp said:
no its not based on the template.
after you export an Excel file is
created, right (strFileName).

use (strFileName) and open this one:

...Worbooks.Open(strFileName, False, False)
Click to expand...

Ok I had already just tried that. I am still getting the same error as mentioned above in the module and according to Microsoft:
An identifier beginning with a period is valid only within a With block. This error has the following cause and solution:
• The identifier begins with a period. Complete the qualification of the identifier or remove the period.
Click to expand...

so the .Range is causing a problem because there is no "With" block?

I changed the module code to look like this:
Code: 
Public Function fnLastRow(sh As Object)
On Error Resume Next
        With xlSheet
                fnLastRow = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=2, _
                                LookIn:=5, _
                                SearchOrder:=1, _
                                SearchDirection:=2, _
                                MatchCase:=False).row
        End With
End Function

and now I get a "runtime error 1004 Application-defined or object-defined error" and it highlights this code in the button code:
Code: 
.Range("F1:F" & lngRow).Select
 
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
one more thing, we need to close
xlObj before exiting the Sub


....
....
xlObj.Quit
Set xlObj=Nothing
End Sub
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
In case I have not mentioned it... thank you so much for all of the help you are giving me.
 
P

psyc0tic1

Access Moron
Local time
Yesterday, 23:49
Joined
Jul 10, 2017
Messages
360
Here is all the current code now:

Module:
Code: 
Public Function fnLastRow(sh As Object)
On Error Resume Next
        With xlSheet
                fnLastRow = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=2, _
                                LookIn:=5, _
                                SearchOrder:=1, _
                                SearchDirection:=2, _
                                MatchCase:=False).row
        End With
End Function

Form Button:
Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"

Dim xlWB As Object
    Dim xlObj As Object
    Dim xlSheet As Object
    Dim lngRow As Long
    
    Set xlObj = CreateObject("Excel.Application")
    
    Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
    
    For Each xlSheet In xlWB.WorkSheets
        
        With xlSheet
            
            
            lngRow = fnLastRow(xlSheet)
            Debug.Print lngRow
            
            .Range("F1:F" & lngRow).Select
            xlObj.Selection.FormatConditions.Add Type:=2, Formula1:= _
                    "=TODAY()-F1<13"
            xlObj.Selection.FormatConditions(xlObj.Selection.FormatConditions.Count).SetFirstPriority
            With xlObj.Selection.FormatConditions(1).Interior
                .PatternColorIndex = -4105
                .Color = 255
                .TintAndShade = 0
            End With
            xlObj.Selection.FormatConditions(1).StopIfTrue = False
            
        End With

Next
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing

End Sub
 
arnelgp

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 12:49
Joined
May 7, 2009
Messages
19,246
Replace xlSheet with sh from the last code I gave you
 
Cronk

Cronk

Registered User.
Local time
Today, 14:49
Joined
Jul 4, 2013
Messages
2,774
That should be
Code: 
Public Function fnLastRow(sh As Object) On Error Resume Next         'With xlSheet
         with sh
....

And I presume you have set a reference in Tools | Reference to Excel
 
You must log in or register to reply here.

Similar threads

W
  • Question
Solved Excel xls-Export
Replies
6
Views
454
wanzi
W
T
Solved Append table to excel file
Replies
8
Views
918
ebs17
E
MattBaldry
Solved Export to Spreadsheet and Name Tab
Replies
6
Views
551
MattBaldry
MattBaldry
D
Export to Excel not working correctly
Replies
3
Views
788
Pat Hartman
P
oxicottin
Solved Export search form data to excel
Replies
11
Views
692
oxicottin
oxicottin

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Top Bottom