Export to Excel code tweaking (1 Viewer)

[psyc0tic1]

Hi all,

After much valuable help from arnelgp I now have working code to export data to Excel with all of the formatting I was looking for.

Just a couple of tweaks needed so I decided to start a new thread rather than it being lost at the end of a 3 page thread.

The below code uses 8 queries to export 7 fields data to Excel with a sheet for each query unless there is no relevant data, then it does not make a sheet for that facility. It then formats column F cells in red if the date is older than 13 days from today. It then formats the header row and the column widths. (I recorded a macro for the additional formatting and pasted the code in the code that arnelgp wrote for me).

3 small issues though.

Issue #1: this export somehow is leaving the Excel process running on my computer and if I try to run the report again (whether I delete the created exported file or not) I get an error

Run-time error 91" "Object variable or With block variable not set

and the debugger highlights the line

Selection.FormatConditions(1).StopIfTrue = True

and I have to open the task manager and end the Excel process to run the report again.

Issue #2: The data that is exported to column D which is the part number is exporting the ID of the part number rather than the actual part number. I am sure the reason is due to the relationship between the "Parts" table and the "Audit Data" table but this relationship cannot be changed or it will mess up other things in my forms and reports. Using the DoCmd.OutputTo method that the macro would use outputs the actual part numbers but using the DoCmd.TransferSpreadsheet method outputs the part number ID number instead.

Issue #3: When I open the exported Excel workbook the A1 cell of the last sheet is selected instead of the A1 cell of the first sheet in the workbook and it makes most of the other sheets be off the page to the left. This is not an issue for me but for the people I am going to send these Excel reports to are not smart enough to click the little arrows or the ... at the bottom left of the workbook to expose the other sheets and they will think they do not have anything in there for them to look at.

Here is the code:

Module:

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

Buttone code:

Private Sub Waiting_on_Lab_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"))

If DCount("*", "AdvanceWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
End If
If DCount("*", "ArcadiaWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
End If
If DCount("*", "EcruWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
End If
If DCount("*", "LeesportWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
End If
If DCount("*", "RipleyWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
End If
If DCount("*", "WanekWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
End If
If DCount("*", "WanvogWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"
End If
If DCount("*", "WhitehallWaitVis") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WhitehallWaitVis", strFileName, True, "WhitehallWaitVis"
End If

    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
            
            .Activate
            'lngRow = fnLastRow(xlSheet)
            lngRow = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp
            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
            Selection.FormatConditions(1).StopIfTrue = True
            Range("A1:G1").Select
            With Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            With Selection.Font
                .Name = "Calibri"
                .FontStyle = "Bold"
                .Size = 11
            End With
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.14996795556505
                .PatternTintAndShade = 0
            End With
            Columns("A:A").Select
            Selection.ColumnWidth = 8.29
            Columns("B:B").Select
            Selection.ColumnWidth = 28.86
            Columns("C:C").Select
            Selection.ColumnWidth = 13.29
            Columns("D:D").Select
            Selection.ColumnWidth = 12.57
            Columns("E:E").Select
            Selection.ColumnWidth = 13.57
            Columns("F:F").Select
            Selection.ColumnWidth = 11
            Columns("G:G").Select
            Selection.ColumnWidth = 13.29
            Range("A1").Select
    End With
            
        End With

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

End Sub

Can someone please help me edit this code to resolve the 3 issues mentioned above?

This is so close to being perfect. At least resolution to issues #1 & #2
I also attached a screenshot of a page in the Excel file to show the formatting accomplished with the above code.

Thank you very much in advance to anyone willing to help with this code.

 

[Gasman]

I don't think your With and End withs match, where you set the font?
As for #3, try seelcting cell A1 on the first sheet before closing?

 

[psyc0tic1]

I don't think your With and End withs match, where you set the font?
As for #3, try seelcting cell A1 on the first sheet before closing?

I was actually looking at the Withs and End Withs when you posted that. I saw a place where I didn't end a With after I set the header row formatting and added an End With which caused me to have to remove the End With at the end of all the code but it didn't fix the instance of Excel still running after the export file creation.

The font is set right after the header row formatting.

As for your suggestion of selecting A1 on the first sheet before closing... since the code omits sheets if there is no data... I don't know how to specify the first sheet if I do not know what the first sheet may be.

 

[Gasman]

Sheets(1).Range("A1").Select

 

[arnelgp]

here is your code:

    Dim xlWB As Object
    Dim xlObj As Object
    Dim xlSheet As Object
    Dim lngRow As Long
    'Dim strFileName As String
    'strFileName = "e:\Waiting on Visual Weekly Report 9-27-2017.xlsx"
    
    Set xlObj = CreateObject("Excel.Application")
    Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
    
    For Each xlSheet In xlWB.Worksheets
        
        With xlSheet
            
            .Activate
            'lngRow = fnLastRow(xlSheet)
            lngRow = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp
            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
            .Range("A1:G1").Select
            With xlObj.Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ReadingOrder = xlContext
                .MergeCells = False
                
                With .Font
                    .Name = "Calibri"
                    .FontStyle = "Bold"
                    .Size = 11
                End With
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                .Borders(xlInsideHorizontal).LineStyle = xlNone
                With .Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = -0.14996795556505
                    .PatternTintAndShade = 0
                End With
            End With
            .Columns("A:A").Select
            xlObj.Selection.ColumnWidth = 8.3
            .Columns("B:B").Select
            xlObj.Selection.ColumnWidth = 28.86
            .Columns("C:C").Select
            xlObj.Selection.ColumnWidth = 13.29
            .Columns("D:D").Select
            xlObj.Selection.ColumnWidth = 12.57
            .Columns("E:E").Select
            xlObj.Selection.ColumnWidth = 13.57
            .Columns("F:F").Select
            xlObj.Selection.ColumnWidth = 11
            .Columns("G:G").Select
            xlObj.Selection.ColumnWidth = 13.29
            .Range("A2").Select
            xlObj.ActiveWindow.FreezePanes = True

                        
        End With

    Next
    xlObj.Sheets(1).Activate
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing

 

[psyc0tic1]

arnelgp you are the most awesome at this. You were able to solve #1 and #3 in on shot!

Thank you very much again. You are really saving me from failure.

One 1 more issue left and that is the "Part Number" showing up and the ID number in the "Parts" table rather than the "Part Number".

This is the only thing left stopping me from being able to roll this function out for use.

 

[arnelgp]

if you can post one of your query then
maybe we can show the partnumber.

i believe partnumber have a lookup field
to some table.

 

[psyc0tic1]

Here is the first query that is used. There are 8 of them that all say the same thing with exception of the facility:

SELECT [Audit Data].Facility, [Audit Data].Status, [Audit Data].[PO Number], [Audit Data].[Part Number], [Audit Data].[Total Received], [Audit Data].RecDate, [Audit Data].RecEntryDate
FROM [Audit Data]
WHERE ((([Audit Data].Facility)="17") AND (([Audit Data].Status)="Waiting on Visual Inspection"));

I attached a screenshot of the relationships to show where the "Part Number" field in the "Audit Data" table has a relationship with the "ID" field in the "Parts" table... this relationship cannot change or some form and report elements will stop working.

Edit: I changed the attached image of the relationships to show all relationships

 

[arnelgp]

use this query:

SELECT [Audit Data].Facility, [Audit Data].Status, [Audit Data].[PO Number], Parts.[Part Number],[Audit Data].[Total Received],[Audit Data].RecDate, [Audit Data].RecEntryDate FROM [Audit Data] Left Join Parts On [Audit Data].[Part Number] = Parts.ID WHERE [Audit Data].Facility="17" And [Audit Data].Status = "Waiting On Visual Inspection"


***
i am unable to see your screenshot.
see Parts table if i put the correct
field name on the query showing
the Part Number from Parts table.

 

[psyc0tic1]

Once again you are the man!

Thank you so much for all of your help. I couldn't have accomplished this without you.

 

[arnelgp]

Ur welcome.

 

[Gasman]

Can someone please explain how the errant Excel process (#1) was solved?, as I cannot see the difference in the code?

TIA

 

[psyc0tic1]

Can someone please explain how the errant Excel process (#1) was solved?, as I cannot see the difference in the code?

TIA

From what I see he added this line:

Selection.FormatConditions(1).StopIfTrue = True

in between:

xlObj.Selection.FormatConditions(1).StopIfTrue = False

and:

Range("A1:G1").Select

Then added:

Selection.

in front of all of the macro code I put in for the formatting.
Then added:

xlObj.Sheets(1).Activate

after "Next" at the end

 

[Gasman]

Not much wiser, but thank you.