VBAコードの最適化

Question

私は以下のコードを持っていますが、非常に遅いです。それを改善する方法はありますか？私はVBAの初心者であり、あなたの助けに感謝します。それはテーブルを通って各ワークシートを検索し、それに応じて値を一致させて与えるための基準です。基準は、最初の範囲でのラインによって異なります

Sub TAB_REF_SETUP() 
    Dim TC As Integer 
    Dim TR As Integer 
    Dim C As Integer 
    Dim C2 As Integer 
    Dim R As Integer 
    Dim R2 As Integer 
    Dim TC2 As Integer 
    Dim TR2 As Integer 
    Dim CELL2 As Range 
    Dim CELL As Range 
    Dim RNG2 As Range 
    Dim RNG As Range 
    Dim WKS As Worksheet 
    Dim a As String 
    Dim xrow As Integer 
    Dim ycol As Integer 
    Dim CEllrow As Integer 
    Dim cellcol As Integer 
    Dim mincol As Integer 
    Dim mfrcol As Integer 
    Dim schrefc As Integer 
    Dim RBC As Integer 
    Dim RTC As Integer 
    Dim b As String 
    Dim CPC As Integer 
    Dim D As String 
    Dim AR As String 
    Dim StartTime As Double 
    Dim SecondsElapsed As Double 
    StartTime = Timer 
    'Application.ScreenUpdating = False 
    Application.AutoCorrect.AutoFillFormulasInLists = False 
    Application.CellDragAndDrop = False 
    Application.Calculation = xlCalculationManual 
    If ActiveSheet.AutoFilterMode = True Then 
     ActiveSheet.ShowAllData 
    Else 
    End If 

    C = Range("1:1").Find("Dist Classification").Column 
    If Range("1:1").Find("Schedule A Ref") Is Nothing Then 
     Columns(C + 1).Insert 
     Columns(C + 2).Insert 
     Columns(C + 3).Insert 
     Cells(1, C + 1).Value = "Schedule A Ref" 
     Cells(1, C + 2).Value = "Contract Name" 
     Cells(1, C + 3).Value = "Lookup Value" 
     schrefc = Range("1:1").Find("Schedule A Ref").Column 
     GoTo CellFill 
    Else 
     schrefc = Range("1:1").Find("Schedule A Ref").Column 
     If MsgBox("Ref Tab Exists. Do you want to proceed with further check?", vbYesNo, "Perform Further Check") = vbYes Then 
      If MsgBox("This will re-write column ""Schedule A Ref"". Do you wish to continue ?", vbYesNo, "Are you sure?") = vbYes Then 
CellFill: 
       TC = Range("A1").End(xlToRight).Column 
       TR = Range("A1").End(xlDown).Row 
       Cells(1, TC + 1) = "Applicable Rebate" 
       Cells(1, TC + 2) = "Applicable Rebate Type" 
       Cells(1, TC + 3) = "Applicable Contract Price" 
       Cells(1, TC + 4) = "Actual Rebate $ for Line" 
       Cells(1, TC + 5) = "Rebate Owed" 
       Set RNG = Range(Cells(2, schrefc), Cells(Range("a1").End(xlDown).Row, schrefc)) 
       mincol = Range("1:1").Find("MIN").Column 
       mfrcol = ActiveSheet.Range("1:1").Find("Mfr Name").Column 
       For Each CELL In RNG 
        CEllrow = CELL.Row 
        For Each WKS In Worksheets 
         If Not WKS.Range("1:1").Find("Schedule") Is Nothing And Not WKS.Range("1:3").Find(Cells(CEllrow, mfrcol)) Is Nothing And (InStr(1, WKS.Name, "fort", vbTextCompare) = 0 And InStr(1, WKS.Name, "report", vbTextCompare) = 0 And InStr(1, WKS.Name, "data", vbTextCompare) = 0) Then 
          C2 = WKS.Range("1:5").Find("Contract Name").Column 
          R2 = WKS.Range("1:5").Find("Contract Name").Row 
          TR2 = WKS.Range("1:5").Find("Contract Name").End(xlDown).Row 
          TC2 = C2 
          Set RNG2 = WKS.Range(WKS.Cells(R2 + 1, C2), WKS.Cells(TR2, C2)) 
          xrow = WKS.Range("1:5").Find("SCC&Tab").Row 
          ycol = WKS.Range("1:5").Find("SCC&Tab").Column 
          RBC = WKS.Range("1:5").Find("Applicable Rebate").Column 
          RTC = WKS.Range("1:5").Find("Applicable Rebate Type").Column 
          CPC = WKS.Range("1:5").Find("Applicable Contract Price").Column 

          a = "=iferror(vlookup([@[Lookup Value]],indirect([@[Schedule A Ref]])," & RBC & ",false),iferror(vlookup([@[Dist Mfr. Item ID]]&[@[Contract Name]],indirect([@[Schedule A Ref]])," & RBC & ",false),""""))" 
          b = "=iferror(vlookup([@[Lookup Value]],indirect([@[Schedule A Ref]])," & RTC & ",false),iferror(vlookup([@[Dist Mfr. Item ID]]&[@[Contract Name]],indirect([@[Schedule A Ref]])," & RTC & ",false),""""))" 
          D = "=iferror(vlookup([@[Lookup Value]],indirect([@[Schedule A Ref]])," & CPC & ",false),iferror(vlookup([@[Dist Mfr. Item ID]]&[@[Contract Name]],indirect([@[Schedule A Ref]])," & CPC & ",false),""""))" 
          For Each CELL2 In RNG2 
           If InStr(1, CELL2, Cells(CEllrow, C), vbTextCompare) > 0 Then 
Filler: 
            CELL.Value = "''" & WKS.Name & "'!" & WKS.Cells(xrow, ycol).Address & ":" & Cells(RNG2.End(xlDown).Row, RNG2.End(xlUp).End(xlToRight).Column).Address 
            Cells(CEllrow, C + 2).Value = CELL2 
            Cells(CEllrow, C + 3).Value = "=[@[Min]]&[@[Contract Name]]" 
            Cells(CEllrow, TC + 1) = a 
            Cells(CEllrow, TC + 2) = b 
            Cells(CEllrow, TC + 3) = D 
            If Cells(CEllrow, TC + 2).Value = "%D" Then 
             AR = "=[@[Applicable Rebate]]*[@[Applicable Contract Price]]*[@[case qty]]" 
            ElseIf Cells(CEllrow, TC + 2).Value = "$" Then 
             AR = "=[@[Applicable Rebate]]*[@[case qty]]" 
            ElseIf Cells(CEllrow, TC + 2).Value = "%P" Then 
             AR = "=[@[Applicable Rebate]]*[@[Total Vol]]" 
            Else 
             AR = "0" 
            End If 
            Cells(CEllrow, TC + 4) = AR 
            Cells(CEllrow, TC + 5) = "=[@[Actual Rebate $ for Line]]-[@[Committed - Rebate]]" 
           ElseIf InStr(1, CELL2, "nat", vbTextCompare) > 0 Then 
            GoTo Filler: 
           Else 
           End If 
          Next 
         Else 
         End If 
        Next 
       Next 
      Else 
       Exit Sub 
      End If 
     Else 
      Exit Sub 
     End If 
    End If 
    Application.AutoCorrect.AutoFillFormulasInLists = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.CellDragAndDrop = True 
    Application.ScreenUpdating = True 
    SecondsElapsed = Round(Timer - StartTime, 2) 

    'Notify user in seconds 
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation 
End Sub 

Answer 1

を行う必要があります。

• コメントを外して、上からこの： Application.ScreenUpdating = False

行うことをお勧め：

を

• integerをlong
• に変更してください。goto statementsを使用しないで書き換えてください。インストールする - >http://www.oaltd.co.uk/indenter/indentpage.aspとインデント。または、コメントに記載されているように、RubberDuck圧子を使用してください。

Answer 2

最も遅い部分は細胞をループしているようです。代わりにこれを使用します。

Dim vData as Variant 
Dim arrayIndex1 as Long, arrayIndex2 as Long 

vData = Range(Cells(2, schrefc), Cells(Range("a1").End(xlDown).Row, schrefc)) 

For arrayIndex1 = lbound(vData) to ubound(vData) 
    For arrayIndex2 = lbound(vData,2) to ubound(vData,2) 
     'vData(arrayIndex1,arrayIndex2)  
    Next arrayIndex2 
Next arrayIndex1 

vData(arrayIndex1,arrayIndex2)はcells(row,col)の配列の対応です。デフォルトで配列は0から始まるので、最初はarrayIndex1になります。デフォルト値を1に変更するには、コードの先頭にOption Base 1を使用します。

より良いコードをわかりやすくするために複数の同一のオブジェクトの使用With声明 - およびループ内の、また、パフォーマンス、例えば代わり​​に：

xrow = WKS.Range("1:5").Find("SCC&Tab").Row 
ycol = WKS.Range("1:5").Find("SCC&Tab").Column 
RBC = WKS.Range("1:5").Find("Applicable Rebate").Column 
RTC = WKS.Range("1:5").Find("Applicable Rebate Type").Column 
CPC = WKS.Range("1:5").Find("Applicable Contract Price").Column 

使用：

With WKS.Range("1:5") 
    xrow = .Find("SCC&Tab").Row 
    ycol = .Find("SCC&Tab").Column 
    RBC = .Find("Applicable Rebate").Column 
    RTC = .Find("Applicable Rebate Type").Column 
    CPC = .Find("Applicable Contract Price").Column 
End With 

また、変数を宣言してみてくださいDim TC As Long, TR As Long, C as Longのように、宣言はコードの行の半分ではありません。オペレーティングシステムはintegerをlongに変換するので、整数は使用しないでください。セル（CEllrow、C）の代わりにCells(CEllrow, C).valueを使用してください。