Proper Error Handling

P

psyc0tic1

Access Moron
Local time
Today, 03:15
Joined
Jul 10, 2017
Messages
360
Hello again,

I have this database that has been mentioned a few times to keep track of electrical parts auditing and testing.

There has been much help here on the export to excel feature I needed added to send weekly reports to testers to show them. The export works great and does exactly what I was looking for.... however

I just discovered today that if there are no records in my database with a status of "Waiting on Lab Testing", the database appears to lock up and I have to get my desktop to show again to see the error prompt that pops up which I have attached a screenshot of.

Is there any way to put in code to make a popup tell me there are no records to export or something like that? I am afraid to tinker with this code... I don't want to break it.

Here is the module:
Code: 
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

Here is the button code:
Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
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 = .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:H1").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 = 15
            .Columns("H:H").Select
            xlObj.Selection.ColumnWidth = 13.29
            .Range("A1").Select
            xlObj.ActiveWindow.FreezePanes = False

                        
        End With

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

End Sub
 

Attachments

  • Capture.JPG
    Capture.JPG
    40.6 KB · Views: 696
Ok, so the excel file has not been created, so it is likely this is the line of code causing the error when executed

Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)

you can step through the code to check this is the case.

Assuming it is this line, then you need some error handing, suggest

Code: 
On Error Resume Next
Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
If Err=0 then

    For Each xlSheet In xlWB.Worksheets

        With xlSheet
            ...
            ....
        End With

    Next
    xlObj.Sheets(1).Activate
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing
end if
 
Here's another method though not quite as neat as CJ London's solution
Additional code in RED

Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
    [COLOR="Red"]Dim N As Integer

    N=0 'count at start[/COLOR]

If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
[COLOR="red"]N=N+1[/COLOR]
End If

[COLOR="red"]
'If N=0 the spreadsheet hasn't been created so exit sub ...
If N=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub
 
CJ_London said:
Ok, so the excel file has not been created, so it is likely this is the line of code causing the error when executed

Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)

you can step through the code to check this is the case.

Assuming it is this line, then you need some error handing, suggest

Code: 
On Error Resume Next
Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
If Err=0 then

    For Each xlSheet In xlWB.Worksheets

        With xlSheet
            ...
            ....
        End With

    Next
    xlObj.Sheets(1).Activate
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing
end if
Click to expand...

CJ_London... Indeed that was the line that was highlighted when it would lock up my database front end. However I tried adding in your code and it didn't change anything... still locked up the same way. Thank you for trying.
 
ridders said:
Here's another method though not quite as neat as CJ London's solution
Additional code in RED

Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
    [COLOR="Red"]Dim N As Integer

    N=0 'count at start[/COLOR]

If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
[COLOR="red"]N=N+1[/COLOR]
End If

[COLOR="red"]
'If N=0 the spreadsheet hasn't been created so exit sub ...
If N=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub
Click to expand...

ridders... I tried your code and it worked... it didn't lock up the database front end anymore. This is simple enough to not care about getting a popup notification explaining there are no records to export. Thank you very much for helping.
 
Or test if the file exists?
 
Also, if a second DCount() > 0 = True, the file will be overwritten. You should create a new filename too, for each acExport.

And whenever I see a repeating block like that I want to write a loop...
Code: 
Private Sub Command35_Click()
    Const FILE_BASE As String = "\Weekly Reports\WaitingOnLabWeeklyReport_{lab}_{date}.xlsx"
    Const LAB_LIST As String = "Advance Arcadia Ecru Leesport Wanek Wanvog"
    Const SHEET_TYPE = acSpreadsheetTypeExcel12Xml
    
    Dim fName As String
    Dim qName As String
    Dim vName
    Dim N As Integer
    
    fName = Replace(FILE_BASE, "{date}", Format$(Date, "yyyymmdd"))
    
    For Each vName In Split(LAB_LIST)
        qName = "qry_" & vName & "waitlab"
        If DCount("*", qName) Then
            DoCmd.TransferSpreadsheet _
               acExport, SHEET_TYPE, qName, Replace(fName, "{lab}", vName), True, vName
            N = N + 1
        End If
    Next
    
    If N > 0 Then
        Dim xlWB As Object
[COLOR="Green"]        'rest of your code here .....[/COLOR]
    End If
End Sub
I'd do something like that,
Mark
 
MarkK said:
Also, if a second DCount() > 0 = True, the file will be overwritten. You should create a new filename too, for each acExport.

And whenever I see a repeating block like that I want to write a loop...
Code: 
Private Sub Command35_Click()
    Const FILE_BASE As String = "\Weekly Reports\WaitingOnLabWeeklyReport_{lab}_{date}.xlsx"
    Const LAB_LIST As String = "Advance Arcadia Ecru Leesport Wanek Wanvog"
    Const SHEET_TYPE = acSpreadsheetTypeExcel12Xml
    
    Dim fName As String
    Dim qName As String
    Dim vName
    Dim N As Integer
    
    fName = Replace(FILE_BASE, "{date}", Format$(Date, "yyyymmdd"))
    
    For Each vName In Split(LAB_LIST)
        qName = "qry_" & vName & "waitlab"
        If DCount("*", qName) Then
            DoCmd.TransferSpreadsheet _
               acExport, SHEET_TYPE, qName, Replace(fName, "{lab}", vName), True, vName
            N = N + 1
        End If
    Next
    
    If N > 0 Then
        Dim xlWB As Object
[COLOR="Green"]        'rest of your code here .....[/COLOR]
    End If
End Sub
I'd do something like that,
Mark
Click to expand...

The file created already has a new file name by using the date. I only run the report once a week on Monday. Also the file gets overwritten already if one with that file name exists.

I have not tested your code yet but I am about to.
 
I *thought* it was writing to different ranges?

MarkK said:
Also, if a second DCount() > 0 = True, the file will be overwritten. You should create a new filename too, for each acExport.

And whenever I see a repeating block like that I want to write a loop...
Code: 
Private Sub Command35_Click()
    Const FILE_BASE As String = "\Weekly Reports\WaitingOnLabWeeklyReport_{lab}_{date}.xlsx"
    Const LAB_LIST As String = "Advance Arcadia Ecru Leesport Wanek Wanvog"
    Const SHEET_TYPE = acSpreadsheetTypeExcel12Xml
    
    Dim fName As String
    Dim qName As String
    Dim vName
    Dim N As Integer
    
    fName = Replace(FILE_BASE, "{date}", Format$(Date, "yyyymmdd"))
    
    For Each vName In Split(LAB_LIST)
        qName = "qry_" & vName & "waitlab"
        If DCount("*", qName) Then
            DoCmd.TransferSpreadsheet _
               acExport, SHEET_TYPE, qName, Replace(fName, "{lab}", vName), True, vName
            N = N + 1
        End If
    Next
    
    If N > 0 Then
        Dim xlWB As Object
[COLOR="Green"]        'rest of your code here .....[/COLOR]
    End If
End Sub
I'd do something like that,
Mark
Click to expand...
 
Gasman said:
Or test if the file exists?
Click to expand...

Much simpler ...!
Remove all the code in RED from my previous post
Add the line shown in BLUE

You could still do a loop as well following Mark's suggestion

Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
 
If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
End If

'If file length  = 0, spreadsheet doesn't exist ... exit routine
[COLOR="Blue"]If Len(Dir(strFileName)=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub
 
ridders said:
Much simpler ...!
Remove all the code in RED from my previous post
Add the line shown in BLUE

You could still do a loop as well following Mark's suggestion

Code: 
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
 
If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
End If

'If file length  = 0, spreadsheet doesn't exist ... exit routine
[COLOR="Blue"]If Len(Dir(strFileName)=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub
Click to expand...

That code throws a syntax error
 
Screenshot not necessary... the error said syntax error and the debugger highlighted the line above he said to insert
Code: 
If Len(Dir(strFileName)=0 Then Exit Sub

I removed his previous code as instructed and inserted the new line as instructed but the line of code stayed red which told me it was not correct and it gave the syntax error when clicking the button
 
My fault. Missing bracket

Code: 
If Len(Dir(strFileName))=0 Then Exit Sub
 
You must log in or register to reply here.

Similar threads

Z
Attempts to make my code more efficient don't work
Replies
5
Views
770
Zedster
Z
T
Solved Append table to excel file
Replies
8
Views
2,172
ebs17
E
L
Retrieve excel from access (vol 4) , extended format , alternative color
Replies
7
Views
1,312
arnelgp
arnelgp
D
Solved Formatting Excel File from Access
Replies
5
Views
1,358
Eugene-LS
Eugene-LS
G
Extract correct leave time
Replies
2
Views
894
goncalo
G

Users who are viewing this thread

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