Question

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

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

第一步是向用户显示一个用户窗体，用户可以在其中选择年份和季度。该代码本身在以下情况下起作用：

我省略了用户表单，然后输入了日期（=变量qVar， yVar和fullDate）直接在代码内部。
我留在用户窗体中，但工作簿的数量从12个减少大概是7个左右。

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

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

重要提示：调试不起作用，因为当我使用F8浏览代码时，调试没有问题。

有问题的用户表单

显式选项

'=================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编辑器中打开表单的情况下打开UserForm数月之久，就会耗尽整个程序。

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

如果您通过按钮调用UserForm，请将其添加到Button_click()子项中。

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

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

希望这会有所帮助！

VBA Excel：“自动化错误。使用UserForm时发生异常。”

1 个答案: