フォルダ内のファイルを全て開きセルの値を紐づけて取得し一覧へ転記したい

Question

前提・実現したいこと

お世話になります。
行き詰っているので教えてください。

実現したいこと：
“marge“フォルダ内の全てのファイル【検索ファイル.xlsm】のC2の値と一致する値を
当該マクロつきファイル【一覧.xlsm】のF列から探し同一行のM列へ
【検索ファイル.xlsm】のS９の値（日付）を転記したいです。

C2の値は３文字以上の数値で
123・456・789 のようになっているケースと
123　のように“・”を含まないケースがあります。
“・”で分割された値をSplitで検索値に指定したいと考えています。

下記コード
‘Noと紐づくItem（日付）を取得
の部分については
こちらのサイトの

VBA:配列　Keyに紐づくItemの格納がうまくいかない
https://teratail.com/questions/348547

の投稿を引用させて頂きました。

コードを載せることも恥ずかしいのですが...
有識者の方のお力をお借り出来ると幸いです。

よろしくお願いいたします。

発生している問題・エラーメッセージ

‘Noと紐づくItem（日付）を取得
With ws exists(No) Then
でエラーになります。

該当のソースコード

‘margeフォルダパス指定
Const Path=”C:\AAA\BBB\CCC\marge\

Dim cnt As Long
Dim I As Long
Dim buf As String
Dim xls As New Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim num As String
Dim No() As String
Dim msg As String

Application.ScreenUpdating=False

‘確認メッセージ
msg=”事前準備①・②は済みましたか？”
If msgBox(msg,vbYesNo)=vbNo Then Exit Sub

‘margeフォルダ内のファイルを全て開き、日付を取得
buf=Dir(Path)

cnt=6

Do While buf <>””

Set wb=xls.Workbooks.Open( Path & buf )
Set ws=wb.Worksheets(“sheet4”)
num=ws.Cells(2,3)

‘dcの作成
Dim dc As Object
Set dc=CreateObject(“Scripting.Dictionary”)

‘検索ファイルのC2の値を”・“で区切り、変数Noへ格納
No=Split(num,”・”)
For i=0 To UBound(No)

‘Noと紐づくItem（日付）を取得
Dim　arr

With ws exists(No) Then
dc.Add No,Array(Array(.Cells(15,6)))
Else
arr=dc(No)
ReDim Preserve arr(UBound(arr)+1)
Arr(UBound(arr))=Array(,Cells(15,6))
End If

‘日付を一覧のM列へ転記
Set ws2=ThisWorkbook.Sheets(“作業シート“)
Ws2.Cells(dc(No),”M”)=.Cells(15,6).Value

End With
Next i

Wb.Close Savechanges:=False

buf= Dir ()

cnt = cnt + 1

Loop

Set xls= Nothing

Application.ScreenUpdating = True

End Sub

コード

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Answer 1

とりあえず、あなたのマクロを修正しました。

Public Sub sample()

    'margeフォルダパス指定
    Const Path = "C:\AAA\BBB\CCC\marge\"
    Dim I As Long
    Dim buf As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim num As String
    Dim No() As String
    Dim msg As String
    Dim dc As Object
    'dcの作成
    Set dc = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    '確認メッセージ
    msg = "事前準備①・②は済みましたか？"
    If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub

    Dim row2 As Long
    Dim maxrow2 As Long
    Set ws2 = ThisWorkbook.Sheets("作業シート")
    maxrow2 = ws2.Cells(Rows.Count, "F").End(xlUp).Row    'F列の最大行取得
    '数値と行番号の記憶
    For row2 = 1 To maxrow2
        num = ws2.Cells(row2, "F").Value
        If num <> "" Then
            dc(num) = row2
        End If
    Next
    'margeフォルダ内のファイルを全て開き、日付を取得
    buf = Dir(Path)
    Do While buf <> ""
        Set wb = Workbooks.Open(Path & buf)
        Set ws = wb.Worksheets("sheet4")
        num = ws.Cells(2, 3)
        '検索ファイルのC2の値を”・“で区切り、変数Noへ格納
        No = Split(num, "・")
        For I = 0 To UBound(No)

            'Noと紐づくItem（日付）を取得
            If dc.exists(No(I)) Then
                row2 = dc(No(I))
                '日付を一覧のM列へ転記
                ws2.Cells(row2, "M") = ws.Cells(15, 6).Value
            End If
        Next I
        wb.Close Savechanges:=False
        buf = Dir()
    Loop
    Application.ScreenUpdating = True
End Sub

Comments

[haru4]

早々にご協力頂き誠にありがとうございます。

読み解きつつ修正作業に取り掛かりますので、こちらのコードについて不明点など発生した際には改めて質問させて頂いてよろしいでしょうか。

今後共よろしくお願いいたします。

[tatsu99]

１．Const Path = "C:\AAA\BBB\CCC\marge\"下には拡張子.xlsm以外のファイルはない前提です。
２．【一覧.xlsm】のF列のデータは１行目から開始している前提です。（1行目は見出し行でない）
上記の前提が成立しない場合は、その旨、補足してください。

[haru4]

についてxlsm形式以外のファイルは存在しませんので問題ありません。
2についてフォーマットの仕様通り6行目からに変更しました。
また、他の部分についてですが
一覧のKey範囲の取得が先になるのですね…！
修正して頂いたもので問題なく動作しております。
大変勉強になりました。本当にありがとうございました。

Answer 2

とりあえず。

With ws
If Not dc.exists(No) Then

Comments

[haru4]

早々のご回答ありがとうございます。
jinoji様に教えて頂いたように、ひとまず修正します。