このVBAブックを開くにはどうすればよいですか？

Question

私は現在、ディレクトリに行くマクロを作成しようとしています。ブックを開き（最終的に合計52の38があります）、2つの列をフィルタリングし、合計を取得します（これを4回繰り返します）。ブック。現在、現在の38のワークブックを処理するのに約7分しかかかりません。

これをスピードアップするにはどうすればよいですか？私はすでに画面更新やイベントを無効にしており、計算方法をxlCalculationManualに変更しました。私はそれが一般的な慣行かどうかはわかりませんが、開いていなくてもワークブックにアクセスする方法を尋ねてきた人々を見てきましたが、画面の更新をオフにする提案が常に行われています。

デバッグモードで実行すると、Workbooks.Open（）は最大10秒かかることがあります。ファイルディレクトリは実際には会社のネットワーク上にありますが、ファイルへのアクセスは通常5秒以内でいつでもかかります。

ブック内のデータには同じポイントが含まれている可能性がありますが、ステータスは異なります。私はすべてのデータを1つのブックにまとめることは可能だとは思わない。

私は直接細胞参照を試します。いくつか結果が出たら、私は自分の投稿を更新します。一般的に

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

速いのExcel VBAマクロを作成する5つのルールがあります。

1. は.Selectメソッドを使用しないでください、

2. は、複数回Active*オブジェクトを使用しないでください

3. 画面更新と自動計算を無効にする

4. は、（検索、オートフィルタなどのような）視覚的なExcelのメソッドを使用しないでください

5. そして

   すべてのほとんどは、代わりに範囲内の個々のセルを閲覧常に使用範囲-配列のコピー。

これらのうち、＃3が実装されています。さらに、ワークシートを再保存することによって、作業の悪化を招いています。視覚的な変更方法（あなたの場合はオートフィルタ）を実行できるだけです。高速化するために必要なことは、これらのルールの残りの部分を最初に実装し、次にソースワークシートを変更して読み取り専用で開くことができないようにすることです。

あなたの問題を引き起こしているこれらの他の望ましくない決定のすべてを強制するコアは、Filters機能の実装方法です。 VBAと比較して遅い（ワークシートを変更したり、冗長なセーブを強制する）ビジュアルなExcel機能ですべてを実行しようとするのではなく、必要なすべてのデータをシートからコピーするだけですあなたのカウントをするためにストレートフォワードVBAコードを使用してください。ここで

は、私はこれらの原則に変換し、あなたのFilters機能の例です。

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 

オートフィルタ/範囲にimplicitnessがたくさんあるので、私はまた、あなたのためにこれをテストしていない可能性があるためご注意ください。元のコードの効果、私はそれが正しいかどうかはわかりません。あなたはそれをしなくてはなりません。

注：これを実装することを決定した場合は、もしあれば、その影響をお知らせください。 （私は何がどのくらいうまくいくか追跡しようとします）