Excel VBA：在大型循環中比較日期的有效方法

Question

節目說明

我正在嘗試使用Sub來從許多文件中生成Raport。 每個文件都由按日期排序的行組成，其中沒有固定數目的行。 有的只有300個，有的超過10000。每一行都按模塊划分，描述了一些類似的問題，每個模塊中也有所有列的總和。 Raport應當在用戶設置的某些文件中顯示在用戶設置的時間內特定模塊出現了多少問題。

問題

我的Sub可以正常工作，但是我不確定我是否做得正確。 一個文件的操作大約需要6秒，但有時大約要2分鍾（最大文件循環中每個文件5000個循環）的時間很長。 我幾乎可以肯定，有更有效的方法來完成這項工作。 我想，主要問題是我檢查每一行中日期的方式-這也是最長的循環。 閱讀后：

• http://www.ozgrid.com/VBA/VBALoops.htm
• 在VBA（Excel）中循環瀏覽行的最有效/最快捷方法是什么？

我不太了解如何在此處應用過濾器或查找功能，我也在嘗試使用Arrays和Foreach ，但是時間執行幾乎是相同的（有時更好，有時不是）。 我也認為許多If和嵌套循環可能會使Sub變慢。 也許在Excel VBA中有一些並行循環或線程使用來加速它？ 我認為Excel總是只使用處理程序的25％。 同樣，我嘗試給用戶一點機會來配置循環作用域（ 代碼中的 Number1和Number2 ），通過良好的設置將時間從2分鍾減少到30秒，但是需要不時檢查和清理DataBase文件，因此這不是最好的解決方案。

我剛剛開始編程，這是我的第一個大項目，所以我意識到代碼質量很差，希望您能為我提供一些指導，以使這只烏龜更快。 抱歉，很長的帖子。

碼

它很大，所以我刪除了一些不太重要的和平（已描述）。

Sub CopyInfo()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Application.EnableEvents = False
   Sheets("Silnik").Select

   'Cleaning cells for raporting (they need to be empty)
    Call Czyść

   'Variable for storing data value
    Dim Value

   'Timer - to see how long it takes
    Dim t As Single
    t = Timer

   'Variables for opening and closing scope of checking data (editable by the user)
    Dim Data1, Data2
    Data1 = Cells(3, 9).Value
    Data2 = Cells(4, 9).Value

   'Position of cells in raport can change (P - row, P2 - column), easy edit
    Dim Postion, Position2
    Position = 9
    Position2 = 13

   'With row should I start looking (N1)? How many rows should I look for dates (N2)?
   'Get search scope values from sheet (these cells are editable by the user)
    Dim Number1, Number2
    Number1 = ActiveWorkbook.Sheets("Silnik").Cells(2, 28)
    Number2 = ActiveWorkbook.Sheets("Silnik").Cells(3, 28)

   'With files should I test? Do I need to test all of them, or just few (LiniaStany)
   'Check state of the file (user can edit with file hes testing)
   'Also - get names of the files (LiniaNazwy) - they can change in time
    Dim LiniaStany(16), LiniaNazwy(16)
    For i = 0 To 15
       LiniaStany(i) = ActiveWorkbook.Sheets("Silnik").Cells(2 + i, 22)
       LiniaNazwy(i) = ActiveWorkbook.Sheets("Silnik").Cells(2 + i, 21)
    Next

   'Variables for workbooks
    Dim wb As Workbook, wb2 As Workbook
    Dim vFile As Variant
   'Set current workbook (to this file)
    Set wb = ActiveWorkbook


   'Core
   'i means currently opened file
    For i = 0 To 15
       'Check if file should be tested, if yes, then set FilePath and open
       If (LiniaStany(i) > 0) Then
          vFile = "C:\Users\Kris\Desktop\kontrol " & LiniaNazwy(i) & " M.xlsm"
          Workbooks.Open vFile
         'Set DataBase workbook
          Set wb2 = ActiveWorkbook
         'Number is currently tested row in chosen file
          For Number = Number1 To Number2
             Value = wb2.Worksheets("Baza").Cells(6 + Number, 1)
             'Check if date is in the scope
             If (Value >= Data1) And (Value <= Data2) Then
                'Get information about SUM of problems in "module1"
                 wb.Sheets("Wyniki").Cells(Position - 1, 4 + i * 3) = wb.Sheets("Wyniki").Cells(Position - 1, 4 + i * 3) + wb2.Worksheets("Baza").Cells(6 + Number, 80)
                 'Check if problems>0, if yes, get more informations
                  If (wb2.Worksheets("Baza").Cells(6 + Number, 80).Value > 0) Then
                      For WK = 0 To 17
                          wb.Sheets("Wyniki").Cells(Position + WK, 4 + i * 3).Value = wb.Sheets("Wyniki").Cells(Position + WK, 4 + i * 3).Value + wb2.Worksheets("Baza").Cells(6 + Number, Position2 + WK).Value
                      Next WK
                  End If
                 'Get information about SUM of problems in "module2"
                  wb.Sheets("Wyniki").Cells(Position + 18, 4 + i * 3) = wb.Sheets("Wyniki").Cells(Position + 18, 4 + i * 3) + wb2.Worksheets("Baza").Cells(6 + Number, 82)
                  If (wb2.Worksheets("Baza").Cells(6 + Number, 82).Value > 0) Then
                      For ZAP = 0 To 9
                         'ZAP - Detale
                          wb.Sheets("Wyniki").Cells(Position + ZAP + 18, 4 + i * 3).Value = wb.Sheets("Wyniki").Cells(Position + ZAP + 18, 4 + i * 3).Value + wb2.Worksheets("Baza").Cells(6 + Number, Position2 + ZAP + 17).Value
                      Next ZAP
                  End If
                  'Some more ifs (7)..., same way, cut out
                  '...
                  '...
            End If
            'See if row is empty or not - if yes, stop the main loop
            If (Value < 1) Then
                Exit For
            End If
        Next Number
        'Close DataBase workbook, go to another one
        wb2.Close False
    End If
Next

Sheets("Raport").Select
Application.ScreenUpdating = screenUpdateState
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = eventsState

Beep
MsgBox "Operation time: " & Timer - t & " seconds."

End Sub

Answer 1

正如我在一段時間后發現的那樣，不需要像這樣循環比較日期。 決不。 Excel提供了篩選器，這些篩選器只能用於將滿足某些條件的單元格范圍縮小到篩選器中所述的條件。 最簡單的方法是打開宏記錄器並在單元格范圍內設置過濾器。 代碼應如下所示（在注入dateStart和dateEnd之后）：

With Sheet1

            .AutoFilterMode = False

            .Range("A1:D1").AutoFilter

            .Range("A1:D1").AutoFilter Field:=2, Criteria1:=">=dateStart", _

             Operator:=xlAnd, Criteria2:="<=dateEnd"

    End With

但是，如果我們使用此過濾器遍歷范圍，則仍然可以獲得相同的結果。 為了提高效率，我們只需要使用可見（已過濾）的單元格即可。 為此，我們可以使用特殊的單元格 ：

Set rng = Range("A2:D50")

For Each cl In rng.SpecialCells(xlCellTypeVisible)
    'Do something on cells in date range
Next cl

用此方法替換外循環后，可以從不同的列中過濾掉其他選項（添加具有不同字段和條件的不同過濾器）。 這樣，根本就不需要使用for循環 。 使用這種方法可以將時間從幾分鍾減少到幾秒鍾。