VBA Excel：“自动化错误。出现异常。” 使用用户窗体时

Question

几天后，我发表了这篇文章，但代码更少，而且我尝试了一些新的东西（未成功）。

我的代码将数据从一张纸复制到另一张纸。 总共有 12 个工作簿，每个工作簿从 6 个工作簿中获取数据。

第一步是我向用户展示一个 UserForm，他们可以在其中 select 一年零一个季度。 代码本身在以下情况下有效：

我省略了 Userform 并直接在代码中输入日期（= 变量qVar 、 yVar和fullDate ）。
我留在用户窗体中，但将工作簿的数量从 12 个减少到 7 个左右。

如果我将 UserForm 与所有 12 个工作簿一起使用，我会得到

“自动化错误。发生异常。”

重要提示：调试不起作用，因为当我通过代码使用 F8 到 go 时，它可以正常工作。

有问题的用户表单

选项显式

'=================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

错误处理用户窗体

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

实际代码

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

最初我让 12 个工作簿保持打开状态，我认为这可能会导致问题，但对于我的新版本代码，我可以说不会。

Answer 1

我想我找到了解决方案。 在没有先在VBA编辑器中打开窗体的情况下打开用户窗体长达数月之久，这会浪费整个程序。

另一个线程指出，Excel更改为并行加载表格，因此，当一件完成在另一件之前完成时，它将导致整个崩溃。 就像您的朋友仍在3个街区之外时，您在“这里”给您发短信时一样，如果您在他们到达您的房子之前就出门，您就会丧命。 无论如何。

如果使用按钮调用UserForm，请将其添加到Button_click()子级。

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

它告诉Excel单击按钮后立即加载表单，而不是先加载进入表单的所有内容。 这实际上与打开VBA窗口相同。

希望这可以帮助！

Answer 2

这个解决方案对我有用。 注意 - 您必须更改 Excel 中的宏安全设置才能生效。 转到 Excel -> 选项 -> 信任中心 -> 信任中心设置 -> 宏设置 -> 并选中“信任访问 VBA 项目 object 模型”复选框。

VBA Excel：“自动化错误。出现异常。” 使用用户窗体时

问题描述

1 个解决方案

解决方案1
1 2019-06-28 17:41:46

解决方案2
-1 2023-01-09 13:10:21

VBA Excel：“自动化错误。 出现异常。” 使用用户窗体时

问题描述

1 个解决方案

解决方案1 1 2019-06-28 17:41:46

解决方案2 -1 2023-01-09 13:10:21

VBA Excel：“自动化错误。出现异常。” 使用用户窗体时

解决方案1
1 2019-06-28 17:41:46

解决方案2
-1 2023-01-09 13:10:21