Automation Error (?) while running Looped VBA Macro

[muppetbrown]

Good Morning

While executing my looped Excel VBA code after around 10 runs of the loop all Excel workbooks that are currently open close without notification. There doesn't seem to be a pattern in this happening though, the number of loops it goes through is not constant and it sometimes shows automation error, and sometimes doesn't.

Unless it is necessary I'm not going to post the code yet because it is rather large and I can't isolate the problem. If there is a way to isolate the problem that would be great. I also know my code could be a lot cleaner but I am still learning a lot of the simple tricks regarding this.

Thank you

[VBA FTW]

What action(s) is your loop performing?

[muppetbrown]

This is the code here:

    For I = 1 To lastRow
        GLB_facility = Range("T" & I).Value
        Call CreateNamedWorkbook
        If Workbooks(GLB_workname).Sheets("REPORTS").CheckBox1.Value = True Then
            Call Mail_workbook_Outlook
        End If
        Set GLB_filename = Nothing
        Set GLB_workname = Nothing
        Set GLB_facility = Nothing
        'Set GLB_currentSheet = Nothing
        Set GLB_yearNum = Nothing
        'Set GLB_colNum = Nothing
    Next

It takes a site name from a list and creates a new workbook with data from a single Excel database that relates to that site. Formats the new workbook, saves, and places it in an email if that option is selected.

[Norie]

Can you post the code for the subs that are called with this code?

[muppetbrown]

This is the first Call

Private Sub CreateNamedWorkbook()
    'On Error GoTo ErrorHandler

    Dim strPath As String
    Dim adacSheetCount, I As Integer
    
    strPath = **removed directory**
    GLB_workname = ActiveWorkbook.Name

    GLB_filename = GLB_facility & " - Staff Record of Learning " & Day(Date) & "-" & Month(Date) & "-" & Year(Date)
    Workbooks.Add.SaveAs Filename:=(strPath & GLB_filename), FileFormat:=51
    GLB_filename = GLB_filename & ".xlsx"
    Workbooks(GLB_filename).Sheets("Sheet2").Delete
    Workbooks(GLB_filename).Sheets("Sheet3").Delete
    
    adacSheetCount = Workbooks(GLB_workname).Sheets.Count
    
'    I = 9
    
    For I = 1 To adacSheetCount
        If Workbooks(GLB_workname).Sheets(I).Name <> "CPP Movements" And Workbooks(GLB_workname).Sheets(I).Name <> "REPORTS" Then
            Workbooks(GLB_filename).Sheets.Add After:=Sheets(Sheets.Count)
            GLB_currentSheet = Workbooks(GLB_workname).Sheets(I).Name
            Workbooks(GLB_filename).Sheets(Sheets.Count).Name = GLB_currentSheet
            Workbooks(GLB_workname).Sheets(I).Activate
            Call MoveInfoTemp
            Call SheetHeaderSetup
            Call MoveInfoFinal
        End If
    Next
    
    Workbooks(GLB_filename).Sheets("Sheet1").Delete
    Workbooks(GLB_filename).Save
    Workbooks(GLB_filename).Close
    Workbooks(GLB_workname).Sheets("REPORTS").Activate
'Exit Sub
'ErrorHandler:
'    MsgBox "CreateNamedWorkbook"
'    Resume Next
End Sub

Then this runs

Private Sub MoveInfoTemp()
    On Error GoTo ErrorHandler

    Dim facColNum, lastRow, lastCol, firstCol, firstRow, I As Integer
    Dim toCopy As Range
        
    Range("A1").Select
    Cells.Find(What:="Employee #", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Select
    firstRow = ActiveCell.Row
    lastCol = Cells(firstRow, 100).End(xlToLeft).Column
    Cells(firstRow, 1).Select
    lastRow = Range("A65536").End(xlUp).Row
    facColNum = Application.WorksheetFunction.Match("Facility", Range(firstRow & ":" & firstRow), 0)

    ActiveSheet.Range(Cells(firstRow, 1), Cells(lastRow, lastCol)).AutoFilter Field:=facColNum, Criteria1:=GLB_facility
    
    Set toCopy = ActiveSheet.Range("A" & firstRow & ":A" & lastRow)
    For I = 2 To lastCol
        If Cells(firstRow, I).Interior.ColorIndex = 55 Then
            Set toCopy = Union(toCopy, ActiveSheet.Range(Cells(firstRow, I), Cells(lastRow, I)))
        End If
    Next
    toCopy.Copy
    Workbooks(GLB_filename).Sheets("Sheet1").Paste
    GLB_colNum = Workbooks(GLB_filename).Sheets("Sheet1").Cells(1, 100).End(xlToLeft).Column
    ActiveSheet.Range(Cells(firstRow, 1), Cells(lastRow, lastCol)).AutoFilter
Exit Sub
ErrorHandler:
    MsgBox "MoveInfoTemp"
'    Resume Next
End Sub

Then this:

Private Sub SheetHeaderSetup()
    On Error GoTo ErrorHandler

    Dim procYear, I, dateColNum As Integer
    Dim maxDate, minDate, dateColLet As Date
    
    Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A1").Value = GLB_facility
    With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A1").Interior
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
    End With
    With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A1").Font
        .Name = "Arial"
        .Size = 24
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.399975585192419
    End With
    Workbooks(GLB_filename).Sheets(GLB_currentSheet).Activate
    With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range(Cells(1, 1), Cells(1, GLB_colNum))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range(Cells(1, 1), Cells(1, GLB_colNum)).Merge
    
    Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A2").Value = Workbooks(GLB_workname).Sheets(GLB_currentSheet).Range("A1").Value
        With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A2").Interior
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0
    End With
    With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A2").Font
        .Name = "Arial"
        .Size = 14
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
        With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range(Cells(2, 1), Cells(2, GLB_colNum))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range(Cells(2, 1), Cells(2, GLB_colNum)).Merge
    
    Workbooks(GLB_filename).Sheets("Sheet1").Activate

    dateColNum = Application.WorksheetFunction.Match("Date", Range("1:1"), 0)
    
    maxDate = Application.WorksheetFunction.Max(Range(Cells(1, dateColNum), Cells(100000, dateColNum)))
    minDate = Application.WorksheetFunction.Min(Range(Cells(1, dateColNum), Cells(100000, dateColNum)))
    
    procYear = Year(minDate)
    GLB_yearNum = 3
    
    If minDate <> 0 Then
        Workbooks(GLB_filename).Sheets(GLB_currentSheet).Activate
    
        Do While procYear - 1 <> Year(maxDate)
            Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A" & GLB_yearNum).Value = procYear & " Staff Totals"
            With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A" & GLB_yearNum).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.249977111117893
                .PatternTintAndShade = 0
            End With
            With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A" & GLB_yearNum).Font
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
            End With
            Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("A" & GLB_yearNum).Font.Bold = True
            
            Workbooks(GLB_filename).Sheets("Sheet1").Activate
            Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range("B" & GLB_yearNum).Value = (Application.WorksheetFunction.CountIf(Workbooks(GLB_filename).Sheets("Sheet1").Range(Cells(1, dateColNum), Cells(100000, dateColNum)), "<" & DateSerial(procYear + 1, 1, 1)) - Application.WorksheetFunction.CountIf(Workbooks(GLB_filename).Sheets("Sheet1").Range(Cells(1, dateColNum), Cells(100000, dateColNum)), "<" & DateSerial(procYear, 1, 1)))
            Workbooks(GLB_filename).Sheets(GLB_currentSheet).Activate
            
            With Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range(Cells(GLB_yearNum, 2), Cells(GLB_yearNum, GLB_colNum))
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            Workbooks(GLB_filename).Sheets(GLB_currentSheet).Range(Cells(GLB_yearNum, 2), Cells(GLB_yearNum, GLB_colNum)).Merge
            
            GLB_yearNum = GLB_yearNum + 1
            procYear = procYear + 1
        Loop
    End If
Exit Sub
ErrorHandler:
    MsgBox "SheetHeaderSetup"
'    Resume Next
End Sub

And finally:

Private Sub MoveInfoFinal()
    On Error GoTo ErrorHandler

    Dim lastRow, lastCol As Integer
    
    Workbooks(GLB_filename).Sheets("Sheet1").Activate
    lastRow = Range("A65536").End(xlUp).Row
    
    Range(Cells(1, 1), Cells(lastRow, GLB_colNum)).Copy
    Workbooks(GLB_filename).Sheets(GLB_currentSheet).Activate
    Range("A" & GLB_yearNum).Select
    ActiveSheet.Paste
    ActiveCell.Columns("A:" & ColLett(GLB_colNum)).EntireColumn.EntireColumn.AutoFit
    
    Workbooks(GLB_filename).Sheets("Sheet1").Delete
    Workbooks(GLB_filename).Sheets.Add Before:=Sheets(1)
    Workbooks(GLB_filename).Sheets(1).Name = "Sheet1"
Exit Sub
ErrorHandler:
    MsgBox "MoveInfoFinal"
'    Resume Next
End Sub

[Norie]

Where does the code error?

[muppetbrown]

Where does the code error?

That is one of the issues, I have no idea. It starts creating the workbooks without any issues, but once it gets to workbook ~10 it all closes. If you can suggest some way to isolate where the code errors that would be fantastic.

[Norie]

I take it there's no debug option when you get the error?

You could step through the code using F8.

Breakpoints (F9) can also be set up to halt the code at certain places.

You can combine the two.

For example set up a breakpoint on a line before a section of 'suspicious' code.

Then run the code to that point as normal and step through the next section of code.

One place it might be worth looking at is the sub 'Mail_workbook_Outlook' where presumably you are automating Outlook.

[muppetbrown]

Thank you for the quick replies.

With your tips I've narrowed the crashes down to the MoveInfoFinal sub, but this is where it goes weird. I've placed a breakpoint at the line "Private Sub MoveInfoFinal()" and then hold down F5 to continue when it gets to that block and the whole thing runs fine and doesn't crash for the whole execution. Any idea of what is happening?

[Norie]

Another thing you can do to help find errors is remove code like this.

On Error GoTo ErrorHandler

I don't know if that will help but perhaps worth a try.

As for that particular sub, nothing sticks out as a potential problem.

The code could do with a tidy up, using Activate/Select isn't needed, but I don't know if that would make a difference.

[muppetbrown]

Thank you

I've tried this as well, still having the issues. Could the speed that the code is running at being the cause?

[Norie]

Have you tried commenting out the call to the sub that you think's causing the problem?

You could also tidy up the code in that sub.

Option Explicit

Private Sub MoveInfoFinal()
Dim wb As Workbook
Dim lastRow As Long

    Set wb = Workbooks(GLB_filename)
    
    With wb.Sheets("Sheet1")
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
       .Range("A1", .Cells(lastRow, GLB_colNum)).Copy wb.Sheets(GLB_CurrentSheet).Range("A" & GLB_yearNum)
    End With
    
    wb.Sheets(GLB_CurrentSheet).UsedRange.EntireColumn.AutoFit
    
    With wb
        .Sheets("Sheet1").Delete
        .Sheets.Add Before:=Sheets(1)
        .Sheets(1).Name = "Sheet1"
    End With
    
End Sub

[muppetbrown]

Thank you Norie, that cleaned code has seemed to fix the problem.