VBA Excel: «Ошибка автоматизации. Возникло исключение. »При использовании пользовательской формы - PullRequest
Новая
       16

VBA Excel: «Ошибка автоматизации. Возникло исключение. »При использовании пользовательской формы

0 голосов
/ 16 мая 2019

Несколько дней я сделал это сообщение, но с меньшим количеством кода и попробовал что-то новое (безуспешно).

Мой код копирует данные с одного листа на другой.Всего 12 рабочих книг, каждая из которых содержит данные из 6 рабочих книг.

Первым делом я показываю пользователю пользовательскую форму, где он может выбрать год и квартал.Сам код работает, когда:

  1. Я опускаю пользовательскую форму и вводю дату (= переменные qVar, yVar и fullDate) непосредственно внутри кода.

  2. Я оставляю в пользовательской форме, но сокращаю количество рабочих книг с 12 до, может быть, 7 или около того.

Если я использую пользовательскую форму со всеми 12рабочие книги, я получаю

«Ошибка автоматизации. Произошло исключение.»

enter image description here

Важно: Отладка не выполняетсяне работает, потому что когда я использую 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 рабочих книг и подумал, что это может вызвать проблему, но с новой версией моего кода я могу сказать, что это не так,

1 Ответ

0 голосов
/ 28 июня 2019

Я думаю, что нашел решение для этого.В течение нескольких месяцев открытие пользовательской формы без предварительного открытия формы в редакторе VBA приводило бы к полной загрузке программы.

В другом потоке указывалось, что Excel переключился на параллельную загрузку форм, поэтому после завершения одного фрагментаперед другим это приводит к краху.Почти как ваш друг пишет вам «здесь», когда они еще в 3 кварталах, и если вы выходите на улицу, прежде чем они доберутся до вашего дома, вы умрете.В любом случае.

Если вы вызываете свою пользовательскую форму с помощью кнопки, добавьте ее в подпрограмму Button_click(). 

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

Она сообщает Excel, чтобы загрузить форму, как только вы нажмете кнопку,вместо загрузки всего, что входит в форму первым.По сути, это то же самое, что и открытие окна VBA.

Надеюсь, это поможет!

...