时间戳

首页 > 解决方案 > VBA 将公式应用于给定范围的时间太长

excel - VBA 将公式应用于给定范围的时间太长

问题描述

请参阅下面的附图。VBA 代码需要 30 多分钟才能根据最新季度信息更新 F 列中的公式直到最后一行。

在此处输入图像描述

例如，如果我有Q1 数据和Q2 数据，那么公式应该根据 Q2 数据计算，因为它是最新的季度。 这是一个主要要求。

我做了以下事情。

1）为每个季度/列创建了一个命名的rages
Q1 =OFFSET(Data!$B$2;0;0;COUNTA(Data!$A:$A)-1;1)；
Q2 =OFFSET(Data!$C$2;0;0;COUNTA(Data!$A:$A)-1;1);
Q3 =OFFSET(Data!$D$2;0;0;COUNTA(Data!$A:$A)-1;1);
Q4 =OFFSET(Data!$E$2;0;0;COUNTA(Data!$A:$A)-1;1);

2) 现在在F 列中，我通过 VBA 代码包含了以下IF条件=IF(Q4_Range>0;E2;IF(Q3_Range>0;D2;IF(Q2_Range>0;C2;IF(Q1_Range>0;B2;""))))

这就是它在 VBA 编辑器中的外观
ActiveCell.FormulaR1C1 =_ "=IF(Q4_Range>0,RC[-1],IF(Q3_Range>0,RC[-2],IF(Q2_Range>0,RC[-3],IF(Q1_Range>0,RC[-4],""""))))"

当我运行 VBA 代码时，复制这个公式需要 30 多分钟，直到最后一行是动态的，大约有 50,000 到 80,000 行。

我的完整代码

Sub Add_Formula()

Dim Sht As Worksheet
Dim LastRow As Long

    Set StartCell = Range("A2")

    LastRow = Sht.Cells(Sht.Rows.Count, StartCell.Column).End(xlUp).Row

      Range("F2:F" & LastRow).Select
      Range("F2:F" & LastRow).FormulaR1C1 = "=IF(FF3_RANGE>0,RC[-1],IF(FF2_RANGE>0,RC[-2],IF(FF1_RANGE>0,RC[-3],IF(FF0_RANGE>0,RC[-4],))))"

      Selection.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"

End Sub

有没有办法通过更改 VBA 代码来加快进程？

标签： excelvbaexcel-formulaexcel-2016

解决方案

以下是一些可以提供帮助的事情：

  1. 如果您在 F 列中只需要最近一个季度的值（单元格 Bx:Ex），那么您可以在不使用动态命名范围的情况下简化您的公式。这个答案为您显示了几个选项，但由于您几乎肯定在查看数字，因此 F 列中的公式应该是=LOOKUP(9.99E+307,$B2:$E2).
  2. 您已经有了使用 VBA 应用公式的正确方法（应该是=LOOKUP(9.99E+307,RC2:RC5)），但您应该始终避免使用SelectorActivate。
  3. 加快进程的真正关键是禁用屏幕更新和自动计算。

将所有内容包装在一起作为示例：

Option Explicit

Sub Add_Formula()
    ToggleAppUpdates False
    Dim Sht As Worksheet
    Set Sht = Worksheets("Sheet1")
    With Sht
        Dim startCell As Range
        Set startCell = .Range("A2")
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, startCell.Column).End(xlUp).Row
        With .Range("F2:F" & lastRow)
            .FormulaR1C1 = "=LOOKUP(9.99E+307,RC2:RC5)"
            .NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
        End With
    End With
    ToggleAppUpdates True
End Sub

Sub ToggleAppUpdates(ByVal state As Boolean)
    With Application
        .ScreenUpdating = state
        .Calculation = IIf(state, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

推荐阅读