VBA优化处理超过200,000个条目

时间：2016-11-07 17:44:58

标签： excel vba excel-vba

我有超过200,000行和9列我正在查看此代码正在运行。我基本上通过输入IfElse语句中的公式的前7行代码循环。我还引用了另一个专栏，如果该条目和＆amp; （第1条）是相同的。这不需要很长时间，但问题是尝试将其复制/粘贴到199,993个条目的其余部分。然后，我有另一个循环，它只是将前一行公式复制并粘贴到下一行，依此类推。这是永远需要的。所以，如果有什么东西会让这个过程更快，我会很感激。目前大约需要25分钟才能运行。

Sub AddFormulas()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim endofcol As Long
Dim endofrow As Long
Dim i As Long
Dim j As Long

endofrow = 2
endofcol = 2

Do Until IsEmpty(Cells(endofcol, 7))
  endofcol = endofcol + 1
Loop

'Find IP30Bopd Column
With ActiveSheet.Range("A1:ZZ1")
  .Find("IP30Bopd").Select
  c = ActiveCell.Column
  r = ActiveCell.Row
End With

For j = 2 To 7
'ActiveSheet.Cells(j, c).Select   ***Don't think it's needed
  For i = c To (c + 8)
    ActiveSheet.Cells(j, i).Select
    If i = c Then
      'IP30Bopd Formula
      ActiveCell.FormulaR1C1 = "=RC[-2]/30.4"
    ElseIf i = c + 1 Then
      'IP30Boed Formula
      ActiveCell.FormulaR1C1 = "=sum(RC[-3]:RC[-2])/6"
    ElseIf i = c + 2 Then
      'IP30BoedX Formula
      ActiveCell.FormulaR1C1 = "=sum(RC[-4]:RC[-3])/14"
    ElseIf i = c + 3 Then
      'IP90Bopd Formula
      ActiveCell.FormulaR1C1 = "=if(R[-2]C[-10]=RC[-10],average(R[-2]C[-3]:RC[-3]),""*"")"
    ElseIf i = c + 4 Then
      'IP90Boed Formula
      ActiveCell.FormulaR1C1 = "=if(R[-2]C[-11]=RC[-11],average(R[-2]C[-3]:RC[-3]),"" * "")"
    ElseIf i = c + 5 Then
      'IP90BoedX Formula
      ActiveCell.FormulaR1C1 ="=if(R[-2]C[-12]=RC[-12],average(R[-2]C[-3]:RC[-3]),"" * "")"
    ElseIf i = c + 6 Then
      'IP180Bopd Formula
      ActiveCell.FormulaR1C1 ="=if(R[-5]C[-13]=RC[-13],average(R[-5]C[-6]:RC[-6]),"" * "")"
    ElseIf i = c + 7 Then
      'IP180Boed Formula
      ActiveCell.FormulaR1C1 = "=if(R[-5]C[-14]=RC[-14],average(R[-5]C[-6]:RC[-6]),"" * "")"
    Else: i = c + 8
      'IP180BoedX Formula
      ActiveCell.FormulaR1C1 = "=if(R[-5]C[-15]=RC[-15],average(R[-5]C[-6]:RC[-6]),"" * "")"
    End If
  Next i
Next j

For j = 7 To (endofcol - 1)
  ActiveSheet.Range(Cells(j, c), Cells(j, c + 8)).Copy    Destination:=ActiveSheet.Cells(j + 1, c)
Next j

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

2 个答案:

答案 0 :(得分：1)

我建议处理数组中的所有条目，并且只有在完成所有计算后才将数组分配给单元格范围

而不是使用ActiveSheet.Cells(j, i).Select使用Dim myArray(2 To 7, c To c + 8)

不要使用公式进行计算，使用vba代码计算数据，要快得多。

完成计算后，将数组指定给图纸范围Range("A1:H7") = myArray
＆＃34; A1：H7＆＃34;只是一个样本，使用你需要的范围。

答案 1 :(得分：1)

不是一行一行地添加公式，而是一次性添加所有公式。

您仍然会在工作表中拥有120万个公式。使用VBA计算和更新值会更有效率。

Option Explicit

Sub AddFormulas()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim Start: Start = Timer
    Dim c As Range, Target As Range
    Dim lastRow As Long
    Dim FormulaR1C1

    FormulaR1C1 = getR1C1Array
    Set Target = Range("A1:ZZ1").Find("IP30Bopd")

    If Not Target Is Nothing Then
        lastRow = Cells(Rows.Count, 1).End(xlUp).Row
        Set Target = Target.Offset(1).Resize(UBound(FormulaR1C1, 1), UBound(FormulaR1C1, 2))
        Target.FormulaR1C1 = FormulaR1C1
        Set Target = Target.Rows(Target.Rows.Count).Resize(lastRow - Target.Rows.Count)
        Target.Rows(1).AutoFill Destination:=Target
        'Uncomment to replace worksheet formulas with their value for better performance
        Application.Calculation = xlCalculationAutomatic

        'Try ConvertR1C1toValues with both True and False to see which is faster
        ConvertR1C1toValues Target, False

    End If

    Debug.Print "Execution Time: "; Timer - Start
    Application.ScreenUpdating = True

End Sub

Sub ConvertR1C1toValues(Target As Range, ColumnbyColumn As Boolean)
    Dim c As Range
    Set Target = Intersect(Target.EntireColumn, Target.Parent.UsedRange)

    If ColumnbyColumn Then
        For Each c In Target
            c.Value = c.Value
        Next
    Else
       Target.Value = Target.Value
    End If
End Sub

Function getR1C1Array()
    Dim data
    ReDim data(6)
    data(0) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[1048574]C[-6]=RC[-6],AVERAGE(RC[9]:R[1048574]C[9]),""*"")", "=IF(R[1048574]C[-7]=RC[-7],AVERAGE(RC[9]:R[1048574]C[9]),"" * "")", "=IF(R[1048574]C[-8]=RC[-8],AVERAGE(RC[9]:R[1048574]C[9]),"" * "")", "=IF(R[1048571]C[-9]=RC[-9],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-10]=RC[-10],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-11]=RC[-11],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")")
    data(1) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[-2]C[-6]=RC[-6],AVERAGE(R[-2]C[9]:RC[9]),""*"")", "=IF(R[-2]C[-7]=RC[-7],AVERAGE(R[-2]C[9]:RC[9]),"" * "")", "=IF(R[-2]C[-8]=RC[-8],AVERAGE(R[-2]C[9]:RC[9]),"" * "")", "=IF(R[1048571]C[-9]=RC[-9],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-10]=RC[-10],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-11]=RC[-11],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")")
    data(2) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[-2]C[-6]=RC[-6],AVERAGE(R[-2]C[-3]:RC[-3]),""*"")", "=IF(R[-2]C[-7]=RC[-7],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-2]C[-8]=RC[-8],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[1048571]C[-9]=RC[-9],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-10]=RC[-10],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-11]=RC[-11],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")")
    data(3) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[-2]C[-6]=RC[-6],AVERAGE(R[-2]C[-3]:RC[-3]),""*"")", "=IF(R[-2]C[-7]=RC[-7],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-2]C[-8]=RC[-8],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[1048571]C[-9]=RC[-9],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-10]=RC[-10],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")", "=IF(R[1048571]C[-11]=RC[-11],AVERAGE(RC[6]:R[1048571]C[6]),"" * "")")
    data(4) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[-2]C[-6]=RC[-6],AVERAGE(R[-2]C[-3]:RC[-3]),""*"")", "=IF(R[-2]C[-7]=RC[-7],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-2]C[-8]=RC[-8],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-5]C[-9]=RC[-9],AVERAGE(R[-5]C[6]:RC[6]),"" * "")", "=IF(R[-5]C[-10]=RC[-10],AVERAGE(R[-5]C[6]:RC[6]),"" * "")", "=IF(R[-5]C[-11]=RC[-11],AVERAGE(R[-5]C[6]:RC[6]),"" * "")")
    data(5) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[-2]C[-6]=RC[-6],AVERAGE(R[-2]C[-3]:RC[-3]),""*"")", "=IF(R[-2]C[-7]=RC[-7],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-2]C[-8]=RC[-8],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-5]C[-9]=RC[-9],AVERAGE(R[-5]C[-6]:RC[-6]),"" * "")", "=IF(R[-5]C[-10]=RC[-10],AVERAGE(R[-5]C[-6]:RC[-6]),"" * "")", "=IF(R[-5]C[-11]=RC[-11],AVERAGE(R[-5]C[-6]:RC[-6]),"" * "")")
    data(6) = Array("=RC[-2]/30.4", "=SUM(RC[-3]:RC[-2])/6", "=SUM(RC[-4]:RC[-3])/14", "=IF(R[-2]C[-6]=RC[-6],AVERAGE(R[-2]C[-3]:RC[-3]),""*"")", "=IF(R[-2]C[-7]=RC[-7],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-2]C[-8]=RC[-8],AVERAGE(R[-2]C[-3]:RC[-3]),"" * "")", "=IF(R[-5]C[-9]=RC[-9],AVERAGE(R[-5]C[-6]:RC[-6]),"" * "")", "=IF(R[-5]C[-10]=RC[-10],AVERAGE(R[-5]C[-6]:RC[-6]),"" * "")", "=IF(R[-5]C[-11]=RC[-11],AVERAGE(R[-5]C[-6]:RC[-6]),"" * "")")

    data = Application.Transpose(data)
    data = Application.Transpose(data)
    getR1C1Array = data

End Function

Function getFormulaR1C1Array(Source As Range)
    Dim r As Range
    Dim Result As String
    Result = "Array("
    For Each r In Source
        Result = Result & Chr(34) & Replace(r.FormulaR1C1, Chr(34), Chr(34) & Chr(34)) & Chr(34) & ","
    Next

    Result = Left(Result, Len(Result) - 1) & ")"

    getFormulaR1C1Array = Result

End Function

UPDATE：

在我可以让公式填充正确之前，我必须走7行深。

从工作表中提取公式数组    - 选择包含公式的1行中的所有单元格    - 在立即窗口中运行此行

  

对于x = 0到6：？＆＃34;数据（＆＃34 ;; x;＆＃34;）=＆＃34 ;; getFormulaR1C1Array（Selection.Offset（x））：Next

enter image description here

相关问题
最新问题