Question

我创建了一个宏，我通过数组公式从软件数据库将数据下载到Excel中。宏的范围是输入开始日期，数据被写入单个Excel文件，然后保存。不幸的是，虽然我使用通常的代码行来加速宏，但宏很慢。另一个问题是数组公式不断地用空行扩展UsedRange，因此文件变得越来越大。为了抵消这种情况，我删除了For Next循环中的空行。最后但并非最不重要的是，我仍然有屏幕闪烁。我的猜测是使用DoEvents，但我需要它来更新数组公式。否则代码将继续而不会下载数据。

以下是我的代码：

Sub Update()

Dim wbTarget As Workbook
Dim objWsInput As Worksheet, objWsMakro As Worksheet, objWsDerivative, objWsFile
Dim Inbox1 As Variant
Dim strFormula As String, strFilename As String, strDate As String
Dim lngDate As Long
Dim dDay As Date

Set objWsInput = ThisWorkbook.Worksheets("INPUT")

'Input start date
Inbox1 = InputBox("Geben Sie bitte ein Start-Datum ein!", Default:=Format(Date, "DD.MM.YYYY"))

Call EventsOff

For dDay = DateSerial(Year(Inbox1), Month(Inbox1), Day(Inbox1)) To DateSerial(Year(Now), Month(Now), Day(Now))
    If Weekday(dDay) <> 1 And Weekday(dDay) <> 7 Then

        'Convert date into DateValue & string
        strDate = Format(dDay, "YYYYMMDD")
        lngDate = DateValue(dDay)


        'Delete contents
        With objWsInput
            .Activate
            .UsedRange.ClearContents

            'Set array formula for QPLIX
            strFormula = "=DisplayAllocationWithPreset(""5a9eb7ae2c94dee7a0d0fd5c"", ""5b06a1832c94de73b4194ccd"", " & lngDate & ")"
            .Range("A1").FormulaArray = strFormula

            'Wait until refresh is done
            Do
            DoEvents
            Loop While Not Application.CalculationState = xlDone

            'Copy paste
            .Range("A1").CurrentRegion.Copy
            .Range("A1").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False

            'Call last row and delete depth 0 with number format
            i = 2
            Call LastRow
            For i = CountRow To 2 Step -1
                If .Cells(i, 1) = 0 Then .Rows(i).Delete
            Next i

            Call NumberFormat

            'Set file name
            strFilename = "Y:\Risikomanagement\Mandate Positions\QPLIX_Mandate_Positions_" & strDate & ".xlsx"

            'Open file
            Set wbTarget = Workbooks.Add
            Set objWsFile = wbTarget.Worksheets(1)

            'Copy data into new file
            .Range("C1:J" & .Range("A1").CurrentRegion.Rows.Count).Copy Destination:=objWsFile.Range("A1")

            'Save file
            wbTarget.SaveAs Filename:=strFilename
            wbTarget.Close

            Call DeleteBlankRows

        End With

    End If

Next dDay


'Save Workbook
ActiveWorkbook.Save

Call EventsOn

MsgBox "Upload Files erstellt!", vbInformation, "Hinweis"

End Sub

支持功能如下：

Public Sub EventsOff()

'Events ausschalten
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

End Sub

Public Sub EventsOn()

'Events anschalten
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With

End Sub

要完成我的代码，请在此处删除空行和部分。格式化数字：

Sub DeleteBlankRows()

Dim MyRange As Range
Dim iCounter As Long

Set MyRange = ActiveSheet.UsedRange

For iCounter = MyRange.Rows.Count To 1 Step -1

    'Step 4: If entire row is empty then delete it.
    If Application.CountA(Rows(iCounter).EntireRow) = 0 Then
        Rows(iCounter).Delete
    End If

Next iCounter

End Sub

Sub NumberFormat()

Dim r As Range

For Each r In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
    If IsNumeric(r) Then
       r.Value = CDec(r.Value)
       r.NumberFormat = "#,##0.00"
    End If
Next r

End Sub

感谢任何帮助。请提前感谢。

RGDS

Answer 1

似乎DoEvents禁用了通常的加速程序，如：

.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual

我在Call Events Off循环后直接更改了我的代码，包括支持函数DoEvents，闪烁消失了。整个过程也快得多。

使用screenupdating加速代码和屏幕闪烁

1 个答案: