VBA 一括処理

VBAでAファイルと配列に入っている170個のファイルを全て比較するのですが、

ループで配列を更新してファイルを1つづつ取り出しています。

ファイル1つの処理は2秒程度なのですが、170個あるので最低でも340秒かかります。

340秒はかかりすぎなので、何か短縮する方法はないかと思考中です。

思いついたのは一括で処理をすることなのですが、

Aファイルと170個のファイルを一括で比較することは、機能的に無理なのでしょうか？

Aファイルに[キーワード]という記述があれば、他ファイルにも[キーワード]という記述が存在するか確認するコードです

Sub hikaku()

Set this = ThisWorkbook.Worksheets("イベント")

Dim arry As Variant

this_line = this.Cells(Rows.Count, 7).End(xlUp).Row - 1'これは気にしないでください

Label:

 C = 1
 d = 1
 a = a + 1
 e = e + 1
 target = this.Cells(e, 7).Value 

Do While this_line >= a 'ここは気にしないでください

    Do While UBound(Sheet) >= C 'Sheetは170個のファイルが入っている配列です

          Filename = Sheet(C) 1つのファイルを変数に格納
        
         Application.ScreenUpdating = False
     
        If target Like "キーワード" Then
           
           If Call IsContained(target, Filename) True Then
             this.Cells(e, 8).Value = "一致"      
             GoTo Label

           Else
             this.Cells(e, 8).Value = "不一致"
           End If
           
        Else
    
        End If

     C = C + 1
     
     If UBound(Sheet) <= C Then '全てのファイルを読み込めば
      GoTo Label
     End If
     
      Exit Do
     Loop
 Loop
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
End Sub 


Function IsContained(target, Filename) As Boolean

path = Sheet_path(C)

Set open_file = Workbooks.Open(Filename:=path & "\" & Filename, UpdateLinks:=False)

On Error Resume Next
num = WorksheetFunction.Match(target, Workbooks(Filename).Worksheets("シート2").Range("CC10:CC900"), 0)
On Error GoTo 0

If num = 0 Then
   IsContained= False
Else
  IsContained = True
End If

Workbooks(Filename).Close

End Function

mako1972

2020/08/25 02:56

毎回、あなたの質問は的を得ない質問ばかりですね。コードを示してください。

kitasue

2020/08/25 03:48

170個のファイルの内容（３０セルなんですよね？）を一つのシートに貯めておくのも一つの方法かも知れません。データを読み込んだ時のファイルの更新日時もシートに記録しておいて、検索時には、更新日時を記録と比較し、異なっているファイルだけ読み込むとか。運用状況がよく分からないのですが、170個のファイルの内容の更新頻度にもよると思います。

yakumo02

2020/08/25 04:35

>kitasueさんご返信ありがとうございます。このVBAを実行する前に、別シートに貯めておくということでしょうか？

mattuwan

2020/08/25 05:16

そもそも、ひとつのファイルにまとめておいて、見せたいときに見せたいように加工編集して表示してはいかがでしょうか？それから、一番最初にアドバイスがあった、数式での参照はやってみてないのでしょうか？

kitasue

2020/08/25 05:30

> このVBAを実行する前に、別シートに貯めておくということでしょうか？ 170個のファイルの更新頻度が高くなく、検索頻度が高いのであれば、一度読み込んだデータを別シートに貯めておくのも一つの手だと思います。

yakumo02

2020/08/25 06:23

> mattuwanさんご返信ありがとうございます！数式での参照はエラーが多々あり、帰宅後に別マクロにて勉強中です

行動規範の内容に同意します

回答1件

ベストアンサー

数式でやってみました。

時間がない中で焦って作った上に、
行き当たりばったりで書いたのでコードが汚いかも＾＾；
もっとセルへの書き込み回数を減らせると思いますが、
いろいろ試す時間がないのでこの辺で。

セルの位置、シート名等こちらで変えてるかもですので微調整等お願いします。

参考になれば。

ExcelVBA
1Option Explicit
2
3Sub testメイン()
4    Dim sFolder As String
5    Dim vFiles() As Variant
6    Dim rngTarget As Range
7    Dim rngResults As Range
8    Dim rngTemporarily As Range
9    
10    'フォルダーの選択
11    If GetFolderPath(sFolder) = False Then Exit Sub
12    'フォルダー内のエクセルファイルのフルパス一覧取得
13    If GetFileList(sFolder, vFiles) = False Then Exit Sub
14    'セル範囲の取得
15    With ThisWorkbook.Worksheets(1)
16        Set rngTarget = .Range(.Cells(1, "G"), .Cells(.Rows.Count, "G").End(xlUp))
17    End With
18    Set rngResults = rngTarget.Offset(, 1)
19    Set rngTemporarily = rngResults.Offset(, 1).Resize(, UBound(vFiles))
20    
21    '値の存在確認結果の入力
22    SetChkExistence rngTarget, rngResults, rngTemporarily, vFiles
23End Sub
24
25Private Function GetFolderPath(ByRef sPath As String) As Boolean
26    With Application.FileDialog(msoFileDialogFolderPicker)
27        .InitialFileName = ThisWorkbook.Path
28        .AllowMultiSelect = False
29        .Title = "フォルダの選択"
30        If .Show = True Then
31            sPath = .SelectedItems(1)
32            GetFolderPath = True
33        End If
34    End With
35End Function
36
37Private Function GetFileList(ByVal sPath As String, ByRef vFileList As Variant) As Boolean
38    Const cFName As String = "*.xls?"
39    Dim buf As String
40    Dim f As String
41    Dim i As Long
42    Dim v() As Variant
43    ReDim v(1000)
44    
45    buf = Dir(sPath & cFName)
46    
47    Do Until Len(buf) = 0
48        f = sPath & "\" & buf
49        If ThisWorkbook.FullName <> f Then
50            GetFileList = True
51            v(i) = f
52            i = i + 1
53        End If
54        buf = Dir()
55    Loop
56    
57    ReDim Preserve v(i - 1)
58    vFileList = v
59End Function
60
61Private Sub SetChkExistence(ByRef rngTarget As Range, _
62                            ByRef rngResults As Range, _
63                            ByRef rngTemporarily As Range, _
64                            ByVal vList As Variant)
65    Const cmyCountIf As String = "=Not(IsError(Match(YYYY,XXXX!$CC$10:$CC$900,0)))"
66    Const cmyOr As String = "=If(Or(XXXX),""一致"",""不一致"")"
67    Dim ss As Variant
68    Dim s As String
69    Dim v As Variant
70    Dim i As Long
71    
72    For Each v In vList
73        ss = Split(v, "\")
74        ss(0) = "'" & ss(0)
75        ss(UBound(ss)) = "[" & ss(UBound(ss)) & "]Sheet1'"
76        ss = Join(ss, "\")
77        s = Replace(cmyCountIf, "XXXX", ss)
78        s = Replace(s, "YYYY", rngTarget(1).Address(False, True))
79        i = i + 1
80        rngTemporarily.Columns(i).Formula = s
81    Next
82    s = Replace(cmyOr, "XXXX", rngTemporarily.Rows(1).Address(False, True))
83    With rngResults
84        .Formula = s
85        .Value = .Value
86    End With
87    rngTemporarily.ClearContents
88End Sub