VBA Excel: “Automation Error. Exception occurred.” when using UserForm

Question

A few days I made this post, but with less code and I've tried something new (unsuccessfully).

My code copies data from one sheet to another. It's a total of 12 workbooks that get data from 6 workbooks each.

The first step is that I show the user a UserForm, where they can select a year and a quarter. The code itself works when:

I leave out the Userform and enter the date (= the variables qVar, yVar and fullDate) directly inside the code.
I leave in the Userform, but reduce the number of workbooks from 12 to maybe 7 or so.

If I use the UserForm with all 12 workbooks, I get the

"Automation Error. Exception Occurred."

Important: Debugging doesn't work because when I use F8 to go through the code, it works without a problem.

Problematic userform

Option Explicit

'=================UserForm causing problems==============
Private Sub cmdAbbrechen_Click()
    Unload Me
End Sub

Private Sub cmdOk_Click()
    Dim QuartalStr As String
    Dim oControl As Control

    If cboJahr.Value = "" Then
        MsgBox "Bitte Jahr auswählen"
        Exit Sub
    End If

    For Each oControl In frmQuartalsauswahl.fraQuartale.Controls
        If oControl.Value = True Then
            qVar = oControl.Caption
        End If
    Next oControl

    yVar = CStr(cboJahr.Value)

    Select Case qVar
        Case "Q1"
            fullDate = yVar & ".03.31"
        Case "Q2"
            fullDate = yVar & ".06.30"
        Case "Q3"
            fullDate = yVar & ".09.30"
        Case "Q4"
            fullDate = yVar & ".12.31"
    End Select

    Unload Me
    Call MitUserForm.Quartalsbericht
End Sub


Private Sub UserForm_Initialize()
    Dim yearsArray() As Integer
    Dim startyear As Integer
    Dim i As Integer

    startyear = 2017
    i = 0

    Do While startyear <= Year(Date)
        ReDim Preserve yearsArray(i)
        yearsArray(i) = startyear
        startyear = startyear + 1
        i = i + 1
    Loop
    cboJahr.List = yearsArray
End Sub

Error-handling userform

Option Explicit

Private Sub cmdCancel_Click()
    Unload Me
    End
End Sub

Private Sub cmdContinue_Click()
    Unload Me
End Sub

Private Sub cmdContinueNoSave_Click()
    saveVar = False
    Unload Me
End Sub

Private Sub UserForm_Initialize() 'frmFehler
    Me.txtFehlermeldung.Text = Join(ErrorArray, ", ")
End Sub

Actual code

Option Explicit

Public fullDate As String
Public yVar As Long
Public qVar As String
Public saveVar As Boolean

Sub ShowUserformQuartal()
    frmQuartalsauswahl.Show
End Sub

Sub Quartalsbericht()

    Dim VWNumberReal As String
    Dim ErrorMessage As String
    Dim Item As Variant
    Dim FilePath As String
    Dim ErrorCount As Long

'code works if I set date like this:
'yVar = 2018
'qVar = "Q4"
'fullDate = "2018.12.31"


Dim VWArray As Variant
Dim FondsArray As Variant
Dim rng As Range, rngHeader As Range
Dim wbVWQB As Workbook, wb As Workbook
Dim wsVWQB As Worksheet
Dim lCol As Long, lColNew As Long
Dim FondsArt As Variant, VWNumber As Variant
Dim wbClose As Workbook


FilePath = "H:\Report\"

VWArray = Array("21", "21FV", "25", "35", "45", "46", "49", "51", "52", "53", "54", "101")


    saveVar = True
'======================Do files exist?=====================
    For Each VWNumber In VWArray
        If Dir$(FilePath & VWNumber & "Quartalsbericht.xlsx") = "" Then
            ErrorMessage = "Quartalsbericht" & VWNumber
            ReDim Preserve ErrorArray(ErrorCount)
            ErrorArray(ErrorCount) = ErrorMessage
            ErrorCount = ErrorCount + 1
        End If

        If VWNumber = "21FV" Then
            FondsArray = Array("AnlFonds", "AnlMischung", "NW670", "FVNW671", "NW673")
            VWNumber = "21"
            VWNumberReal = "21FV"
        ElseIf VWNumber = "49" Then
            FondsArray = Array("AnlFonds", "AnlMischung", "AnlStreuung", "NW670", "NW671", "NW673")
        ElseIf qVar = "Q4" Then
            FondsArray = Array("AnlFonds", "AnlMischung", "AnlStreuung", "NW670", "NW671", "NW673")
        Else
            FondsArray = Array("AnlFonds", "AnlMischung", "AnlStreuung", "NW670", "NW673")
        End If

        For Each FondsArt In FondsArray

            If Dir$(FilePath & yVar & "\" & fullDate & "\" & VWNumber & FondsArt & qVar & yVar & ".xlsx") = "" Then
                ErrorMessage = VWNumber & FondsArt & qVar & yVar
                ReDim Preserve ErrorArray(ErrorCount)
                ErrorArray(ErrorCount) = ErrorMessage
                ErrorCount = ErrorCount + 1
            End If
        Next FondsArt
    Next VWNumber

If ErrorCount > 0 Then
    frmFehler.Show
End If

Application.ScreenUpdating = False
        For Each VWNumber In VWArray
            If Dir$(FilePath & VWNumber & "Quartalsbericht.xlsx") = "" Then
                GoTo MissingVWFile
            End If

                Set wbVWQB = Application.Workbooks.Open(FilePath & VWNumber & "Quartalsbericht.xlsx")
                wbVWQB.SaveAs FilePath & "Backups\" & VWNumber & "Quartalsbericht_old_" & Format(Now(), "dd-mm-yyyy hh-mm-ss") & ".xlsx"  'backup
                Application.DisplayAlerts = False ' = automatisches Überschreiben der alten Datei
                wbVWQB.SaveAs FilePath & VWNumber & "Quartalsbericht.xlsx" 'ursprünglicher Name, so dass workbooks außerhalb des Loops gespeichert werden können
                Application.DisplayAlerts = True

                If VWNumber = "21FV" Then
                    Debug.Print "Fall 1: " & VWNumber
                    FondsArray = Array("AnlFonds", "AnlMischung", "NW670", "FVNW671", "NW673")
                ElseIf VWNumber = "49" Then
                    Debug.Print "Fall 2: " & VWNumber
                    FondsArray = Array("AnlFonds", "AnlMischung", "AnlStreuung", "NW670", "NW671", "NW673")
                ElseIf qVar = "Q4" Then
                    Debug.Print "Fall 3: " & VWNumber
                    FondsArray = Array("AnlFonds", "AnlMischung", "AnlStreuung", "NW670", "NW671", "NW673")
                Else
                    Debug.Print "Fall 4: " & VWNumber
                    FondsArray = Array("AnlFonds", "AnlMischung", "AnlStreuung", "NW670", "NW673")
                End If

            If VWNumber = "21FV" Then
                VWNumberReal = "21FV"
                VWNumber = "21"
            End If
            Debug.Print "If VW Number = 21FV: Real: " & VWNumberReal & " VWNumber: " & VWNumber


            For Each FondsArt In FondsArray
                If Dir$(FilePath & yVar & "\" & fullDate & "\" & VWNumber & FondsArt & qVar & yVar & ".xlsx") = "" Then
                    GoTo MissingFondsFile
                End If

                Set wb = Application.Workbooks.Open(FilePath & yVar & "\" & fullDate & "\" & VWNumber & FondsArt & qVar & yVar & ".xlsx")
                Set wsVWQB = wbVWQB.Sheets(FondsArt)

                lCol = wsVWQB.Cells(2, Columns.Count).End(xlToLeft).Column + 1

                If VWNumberReal <> "21FV" Then
                    Select Case wb.Name
                        Case VWNumber & "AnlFonds" & qVar & yVar & ".xlsx"
                            If VWNumber = "21" Then
                                wb.ActiveSheet.Range("E1:E1").Copy wbVWQB.Sheets(FondsArt).Cells(2, lCol)
                                wb.ActiveSheet.Range("E31:E118").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                            Else
                                wb.ActiveSheet.Range("D1").Copy wbVWQB.Sheets(FondsArt).Cells(2, lCol)
                                wb.ActiveSheet.Range("D31:D118").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                            End If
                        Case VWNumber & "AnlMischung" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("E1:F200").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "AnlStreuung" & qVar & yVar & ".xlsx"
                            lCol = wsVWQB.Cells(3, Columns.Count).End(xlToLeft).Column + 1
                            wb.ActiveSheet.Range("A9:G200").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "NW670" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("C1:C200").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "NW671" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("C1:F1").Copy wbVWQB.Sheets(FondsArt).Cells(2, lCol)
                            wb.ActiveSheet.Range("C46:F200").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "FVNW671" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("C1:F1").Copy wbVWQB.Sheets(FondsArt).Cells(2, lCol)
                            wb.ActiveSheet.Range("C46:F200").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "NW673" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("C1:C100").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                            wb.ActiveSheet.Range("F1:F100").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol + 1).PasteSpecial xlPasteAllUsingSourceTheme
                    End Select
                Else 'VWNumberReal = "21FV"
                    Select Case wb.Name
                        Case VWNumber & "AnlFonds" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("D1").Copy wbVWQB.Sheets(FondsArt).Cells(2, lCol)
                            wb.ActiveSheet.Range("D31:D118").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "AnlMischung" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("C1:D200").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "NW670" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("D1:D200").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "FVNW671" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("C1:F1").Copy wbVWQB.Sheets(FondsArt).Cells(2, lCol)
                            wb.ActiveSheet.Range("C46:F200").Copy: wbVWQB.Sheets(FondsArt).Cells(3, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                        Case VWNumber & "NW673" & qVar & yVar & ".xlsx"
                            wb.ActiveSheet.Range("D1:D100").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol).PasteSpecial xlPasteAllUsingSourceTheme
                            wb.ActiveSheet.Range("F1:F100").Copy: wbVWQB.Sheets(FondsArt).Cells(2, lCol + 1).PasteSpecial xlPasteAllUsingSourceTheme
                    End Select
                End If


                If FondsArt = "AnlStreuung" Then
                    lColNew = wsVWQB.Cells(3, Columns.Count).End(xlToLeft).Column
                    wsVWQB.Range(wsVWQB.Cells(2, lCol), wsVWQB.Cells(2, lColNew)).Interior.Color = RGB(128, 128, 128) 'grey (empty) header
                Else
                    lColNew = wsVWQB.Cells(2, Columns.Count).End(xlToLeft).Column
                End If

                'year and quarter as headline
                With wsVWQB
                    .Range(.Cells(1, lCol), .Cells(1, lColNew)).Merge
                    .Cells(1, lCol).Value = qVar & " " & yVar
                    .Cells(1, lCol).HorizontalAlignment = xlCenter
                    .Cells(1, lCol).Font.Bold = True
                    .Cells(1, lCol).Font.Color = vbWhite
                    .Cells(1, lCol).Interior.Color = RGB(128, 128, 128)
                    .Range(.Cells(2, lCol), .Cells(2, lColNew)).Font.Bold = True
                    .Range(.Cells(2, lCol), .Cells(2, lColNew)).Font.Color = vbWhite
                End With

                Call LeftBorder(lCol, wbVWQB, wsVWQB)

                wb.Close SaveChanges:=False
MissingFondsFile:
            VWNumberReal = ""
            Next FondsArt
            wbVWQB.Close SaveChanges:=saveVar
            Application.CutCopyMode = False
MissingVWFile:
        Next VWNumber

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

Sub LeftBorder(lCol As Long, wbVWQB As Workbook, wsVWQB As Worksheet)
    Dim lRow As Long
    Debug.Print wsVWQB.Name
    Debug.Print lCol

    With wsVWQB
        Select Case .Name
            Case "AnlMischung"
                .Range(.Cells(1, lCol), .Cells(63, lCol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range(.Cells(1, lCol), .Cells(63, lCol)).Borders(xlEdgeLeft).Weight = xlThick
            Case "AnlStreuung"
                 lRow = .Cells(Rows.Count, lCol + 6).End(xlUp).Row
                .Range(.Cells(1, lCol), .Cells(lRow, lCol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range(.Cells(1, lCol), .Cells(lRow, lCol)).Borders(xlEdgeLeft).Weight = xlThick
            Case "NW671"
                .Range(.Cells(1, lCol), .Cells(73, lCol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range(.Cells(1, lCol), .Cells(73, lCol)).Borders(xlEdgeLeft).Weight = xlThick
            Case "FVNW671"
                .Range(.Cells(1, lCol), .Cells(73, lCol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range(.Cells(1, lCol), .Cells(73, lCol)).Borders(xlEdgeLeft).Weight = xlThick
            Case "NW673"
                .Range(.Cells(1, lCol), .Cells(50, lCol)).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range(.Cells(1, lCol), .Cells(50, lCol)).Borders(xlEdgeLeft).Weight = xlThick
        End Select
    End With
End Sub

Initially I left the 12 workbooks open and I thought this might cause the issue, but with the new version of my code I can say it doesn't.

Have you tried to replace the Unload Me statement by Me.Hide? Unload destroys the form-object, but you need to keep the form alive as long as your code runs. — FunThomas
– FunThomas, Commented May 16, 2019 at 16:18
@FunThomas Doesn't change anything unfortunately (and why would it, what I need from the UF is stored in the global variables, unless I'm overlooking something) — Alex
– Alex, Commented May 17, 2019 at 6:10

Community · Accepted Answer · 2020-06-20 09:12:55Z

3

I think I found the solution for this. For months opening a UserForm without first having the form open in VBA editor would tank the entire program.

Another thread pointed out that Excel changed to loading forms in parallel, so when one piece finishes before the other it causes the whole thing to crash. Almost like your friend texting you "here" when they're still 3 blocks away, and if you head outside before they get to your house you die. Anyways.

If you call your UserForm with a button, add this to the Button_click() sub.

ThisWorkbook.VBProject.VBComponents("UserForm").Activate

It tells Excel to load the form as soon as you click the button, instead of loading everything that goes into the form first. This does essentially the same thing as opening a VBA window.

Hope this helps!

edited Jun 20, 2020 at 9:12

CommunityBot

11 silver badge

answered Jun 28, 2019 at 17:41

Jamie

513 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

Alex Over a year ago

Thanks for answering, I haven't been active here the last couple of months. I tried it, but unfortunately it isn't the solution in my case.

Collectives™ on Stack Overflow

VBA Excel: “Automation Error. Exception occurred.” when using UserForm

1 Answer 1

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related