質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.92%

VBA 一括処理

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 2
  • VIEW 696

score 56

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                   
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • mattuwan

    2020/08/25 14:16

    そもそも、ひとつのファイルにまとめておいて、
    見せたいときに見せたいように加工編集して表示してはいかがでしょうか?

    それから、
    一番最初にアドバイスがあった、数式での参照はやってみてないのでしょうか?

    キャンセル

  • kitasue

    2020/08/25 14:30

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

    キャンセル

  • yakumo02

    2020/08/25 15:23

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

    キャンセル

回答 1

checkベストアンサー

+1

数式でやってみました。

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

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

参考になれば。

Option Explicit

Sub testメイン()
    Dim sFolder As String
    Dim vFiles() As Variant
    Dim rngTarget As Range
    Dim rngResults As Range
    Dim rngTemporarily As Range

    'フォルダーの選択
    If GetFolderPath(sFolder) = False Then Exit Sub
    'フォルダー内のエクセルファイルのフルパス一覧取得
    If GetFileList(sFolder, vFiles) = False Then Exit Sub
    'セル範囲の取得
    With ThisWorkbook.Worksheets(1)
        Set rngTarget = .Range(.Cells(1, "G"), .Cells(.Rows.Count, "G").End(xlUp))
    End With
    Set rngResults = rngTarget.Offset(, 1)
    Set rngTemporarily = rngResults.Offset(, 1).Resize(, UBound(vFiles))

    '値の存在確認結果の入力
    SetChkExistence rngTarget, rngResults, rngTemporarily, vFiles
End Sub

Private Function GetFolderPath(ByRef sPath As String) As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Title = "フォルダの選択"
        If .Show = True Then
            sPath = .SelectedItems(1)
            GetFolderPath = True
        End If
    End With
End Function

Private Function GetFileList(ByVal sPath As String, ByRef vFileList As Variant) As Boolean
    Const cFName As String = "\*.xls?"
    Dim buf As String
    Dim f As String
    Dim i As Long
    Dim v() As Variant
    ReDim v(1000)

    buf = Dir(sPath & cFName)

    Do Until Len(buf) = 0
        f = sPath & "\" & buf
        If ThisWorkbook.FullName <> f Then
            GetFileList = True
            v(i) = f
            i = i + 1
        End If
        buf = Dir()
    Loop

    ReDim Preserve v(i - 1)
    vFileList = v
End Function

Private Sub SetChkExistence(ByRef rngTarget As Range, _
                            ByRef rngResults As Range, _
                            ByRef rngTemporarily As Range, _
                            ByVal vList As Variant)
    Const cmyCountIf As String = "=Not(IsError(Match(YYYY,XXXX!$CC$10:$CC$900,0)))"
    Const cmyOr As String = "=If(Or(XXXX),""一致"",""不一致"")"
    Dim ss As Variant
    Dim s As String
    Dim v As Variant
    Dim i As Long

    For Each v In vList
        ss = Split(v, "\")
        ss(0) = "'" & ss(0)
        ss(UBound(ss)) = "[" & ss(UBound(ss)) & "]Sheet1'"
        ss = Join(ss, "\")
        s = Replace(cmyCountIf, "XXXX", ss)
        s = Replace(s, "YYYY", rngTarget(1).Address(False, True))
        i = i + 1
        rngTemporarily.Columns(i).Formula = s
    Next
    s = Replace(cmyOr, "XXXX", rngTemporarily.Rows(1).Address(False, True))
    With rngResults
        .Formula = s
        .Value = .Value
    End With
    rngTemporarily.ClearContents
End Sub

※エクセルでは、なんでもかんでもまとめてしようとせず、
途中経過を列やシートに仮置きすると、考え方が楽になります。

処理速度が改善されましたら是非お教えください。
こちらも、勉強しながら書いております。
ぜひ情報を共有しましょう。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/08/26 09:49

    ご丁寧にありがとうございます!
    がんばってみます!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.92%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る