Jak mogę szybciej otworzyć skoroszyt VBA?

Question

Obecnie próbuję zrobić makro, które przejdzie do katalogu, otworzyć skoroszyt (obecnie 38 ma ostatecznie 52), filtrować dwie kolumny, uzyskać łączną liczbę (powtórz to 4 razy) i zamknąć skoroszyt. Obecnie zajmuje mi to około 7 minut, aby przetworzyć obecne 38 skoroszytów.

Jak mogę to przyspieszyć? Mam już wyłączone aktualizowanie ekranu, zdarzenia i zmieniłem metody obliczeń na xlCalculationManual. Nie wiem, czy to powszechna praktyka, ale widziałem ludzi pytających o sposób dostępu do skoroszytu bez jego otwierania, ale sugestia wyłączenia aktualizacji ekranu jest zawsze wykonywana, co zrobiłem.

Po uruchomieniu go w trybie debugowania funkcja Workbooks.Open() może zająć do 10 sekund. Katalog plików znajduje się w sieci firmowej, ale uzyskanie dostępu do pliku zwykle trwa zaledwie 5 sekund.

Dane w zeszytach mogą zawierać te same punkty, ale mają inny status. Nie sądzę, że możliwe byłoby połączenie wszystkich danych w jeden skoroszyt.

Mam zamiar eksperymentować z bezpośrednimi referencjami komórek. Po uzyskaniu wyników zaktualizuję mój wpis.

Private UNAME As String 

Sub FileOpenTest() 
Call UserName 
Dim folderPath As String 
Dim filename As String 
Dim tempFile As String 
Dim wb As Workbook 
Dim num As Integer 
Dim values(207) As Variant 
Dim arryindex 
Dim numStr As String 
Dim v As Variant 
Dim init As Integer 
init = 0 
num = 1 
arryindex = 0 
numStr = "0" & CStr(num) 

'Initialize values(x) to -1 
For Each v In values 
values(init) = -1 
init = init + 1 
Next 

With Excel.Application 
     .ScreenUpdating = False 
     .Calculation = Excel.xlCalculationManual 
     .EnableEvents = False 
     .DisplayAlerts = False 
End With 

'File path to save temp file 
tempFile = "C:\Users\" & UNAME & "\Documents\TEMP.xlsm" 
'Directory of weekly reports 
folderPath = "path here" 
'First file to open 
filename = Dir(folderPath & "file here" & numStr & ".xlsm") 
Do While filename <> "" 
     Set wb = Workbooks.Open(folderPath & filename) 
     'Overwrite previous "TEMP.xlsm" workbook without alert 
     Application.DisplayAlerts = False 
     'Save a temporary file with unshared attribute 
     wb.SaveAs filename:=tempFile, AccessMode:=xlExclusive 

     'operate on file 
     Filters values, arryindex 
     wb.Close False 

     'Reset file name 
     filename = Dir 

     'I use this loop to add the appropriate number to the end ie 01, 02, 03 etc 
     If num >= 9 Then 
     num = num + 1 
     If num = 33 Then 
      num = num + 1 
     End If 
     numStr = CStr(num) 
     ElseIf num < 9 Then 
     num = num + 1 
     numStr = "0" & CStr(num) 
     End If 

    filename = Dir(folderPath & "filename here" & numStr & ".xlsm") 
Loop 

output values 

'Delete "TEMP.xlsm" file 
On Error Resume Next 
Kill tempFile 
On Error GoTo 0 
End Sub 

Function Filters(ByRef values() As Variant, ByRef arryindex) 
    On Error Resume Next 
    ActiveSheet.ShowAllData 
    On Error GoTo 0 
    'filter column1 
    ActiveSheet.Range("B6").End(xlDown).AutoFilter Field:=2, Criteria1:=Array(_ 
     "p1", "p2", "p3", "p4", "p5"), Operator:=xlFilterValues 
    'filter column2 
    ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array(_ 
     "s1", "d2", "s3"), Operator:=xlFilterValues 
    'get the total of points 
    values(arryindex) = TotalCount 
    arryindex = arryindex + 1 

    'filter column2 for different criteria 
    ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:="s" 
    'filter colum3 for associated form 
    ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="<>" 
    'get the total of points 
    values(arryindex) = TotalCount 
    arryindex = arryindex + 1 

    'filter coum 3 for blank forms 
    ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="=" 
    'get the total of points 
    values(arryindex) = TotalCount 
    arryindex = arryindex + 1 

    'filter for column4 if deadline was made 
    ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=52 
    ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array(_ 
     "s1", "s2", "s3", "s4", "s5", "s6"), Operator:=xlFilterValues 
    ActiveSheet.Range("BC6").End(xlDown).AutoFilter Field:=55, Criteria1:=RGB(146 _ 
     , 208, 80), Operator:=xlFilterCellColor 
    'get total of points 
    values(arryindex) = TotalCount 
    arryindex = arryindex + 1 

End Function 

Public Function TotalCount() As Integer 
Dim rTable As Range, r As Range, Kount As Long 
Set rTable = ActiveSheet.AutoFilter.Range 
TotalCount = -1 
For Each r In Intersect(Range("A:A"), rTable) 
    If r.EntireRow.Hidden = False Then 
     TotalCount = TotalCount + 1 
    End If 
Next 
End Function 

Function UserName() As String 
    UNAME = Environ("USERNAME") 
End Function 

Function output(ByRef values() As Variant) 
Dim index1 As Integer 
Dim index2 As Integer 
Dim t As Range 
Dim cw As Integer 
'Calendar week declariations 
Dim cwstart As Integer 
Dim cstart As Integer 
Dim cstop As Integer 
Dim data As Integer 
data = 0 
start = 0 
cw = 37 
cstart = 0 
cstop = 3 

ThisWorkbook.Sheets("Sheet1").Range("B6").Activate 

For index1 = start To cw 
    For index2 = cstart To cstop 
    Set t = ActiveCell.Offset(rowOffset:=index1, columnOffset:=index2) 
    t.value = values(data) 
    data = data + 1 
    Next 
Next 

End Function 

Answer 1

Zasadniczo istnieje pięć zasad do tworzenia makr Excel VBA-szybka:

1. Nie używaj .Select metod,

2. nie używaj Active* obiekty więcej niż jeden raz,

3. Wyłączanie aktualizacji ekranu i automatycznych obliczeń,

4. Nie stosować metody wizualne Excel (jak Search, Autofiltru itp),

5. A przede wszystkim, zawsze użycie zakres-array kopiowanie zamiast przeglądania poszczególnych komórek w zakresie.

Spośród nich wprowadzono tylko # 3. Dodatkowo, zaostrzają Państwo sytuację poprzez ponowne zapisywanie arkuszy roboczych, tak aby można było wykonywać metody modyfikacji wizualnych (w przypadku AutoFilter). Aby zrobić to szybko, musisz najpierw wdrożyć pozostałe reguły, a po drugie, przerwać modyfikowanie swoich arkuszy źródłowych, aby można było je otworzyć tylko do odczytu.

Rdzeniem tego, co powoduje problemy i wymuszaniem wszystkich innych niepożądanych decyzji, jest sposób, w jaki zaimplementowano funkcję Filters. Zamiast próbować zrobić wszystko za pomocą wizualnych funkcji programu Excel, które są powolne w porównaniu do (dobrze napisanego) VBA (i które modyfikują arkusze robocze, wymuszając zbędne zapisywanie), po prostu w tablicy zakresów kopiuj wszystkie potrzebne dane z arkusza i użyj prostego kodu VBA, aby wykonać zliczanie.

Oto przykład swojej funkcji Filters że przekształca się w tych zasadach:

Function Filters(ByRef values() As Variant, ByRef arryindex) 
    On Error GoTo 0 
    Dim ws As Worksheet 
    Set ws = ActiveSheet 

    'find the last cell that we might care about 
    Dim LastCell As Range 
    Set LastCell = ws.Range("B6:AZ6").End(xlDown) 

    'capture all of the data at once with a range-array copy 
    Dim data() As Variant, colors() As Variant 
    data = ws.Range("A6", LastCell).Value 
    colors = ws.Range("BC6", "BC" & LastCell.Row).Interior.Color 

    ' now scan through every row, skipping those that do not 
    'match the filter criteria 
    Dim r As Long, c As Long, v As Variant 
    Dim TotCnt1 As Long, TotCnt2 As Long, TotCnt3 As Long, TotCnt4 As Long 
    TotCnt1 = -1: TotCnt2 = -1: TotCnt3 = -1: TotCnt4 = -1 
    For r = 1 To UBound(data, 1) 

     'filter column1 (B6[2]) 
     v = data(r, 2) 
     If v = "p1" Or v = "p2" Or v = "p3" Or v = "p4" Or v = "p5" Then 

      'filter column2 (J6[10]) 
      v = data(r, 10) 
      If v = "s1" Or v = "d2" Or d = "s3" Then 
       'get the total of points 
       TotCnt1 = TotCnt1 + 1 
      End If 

      'filter column2 for different criteria 
      If data(r, 10) = "s" Then 
       'filter colum3 for associated form 
       If CStr(data(r, 52)) <> "" Then 
        'get the total of points 
        TotCnt2 = TotCnt2 + 1 
       Else 
       ' filter coum 3 for blank forms 
        'get the total of points 
        TotCnt3 = TotCnt3 + 1 
       End If 
      End If 

      'filter for column4 if deadline was made 
      v = data(r, 10) 
      If v = "s1" Or v = "s2" Or v = "s3" Or v = "s4" Or v = "s5" Then 
       If colors(r, 1) = RGB(146, 208, 80) Then 
        TotCnt4 = TotCnt4 + 1 
       End If 
      End If 

     End If 

    Next r 

    values(arryindex) = TotCnt1 
    values(arryindex + 1) = TotCnt2 
    values(arryindex + 2) = TotCnt3 
    values(arryindex + 3) = TotCnt4 
    arryindex = arryindex + 4 

End Function 

Należy pamiętać, że ponieważ nie mogę przetestować to dla ciebie i również dlatego, że tam jest dużo implicitness do Autofiltru/zakres efekty w oryginalnym kodzie, nie mogę stwierdzić, czy jest poprawny. Będziesz musiał to zrobić.

Uwaga: jeśli zdecydujesz się na wdrożenie, poinformuj nas o tym, jaki miał wpływ. (Staram się śledzić, co działa i jak dużo)