[[20231105104611]]　『多階層のフォルダ内のファイルをIDで書き出して別』（こそら）　ページの最後に飛ぶ

『多階層のフォルダ内のファイルをIDで書き出して別シートに抽出』（こそら）

・親フォルダに複数の子フォルダがある

・子フォルダには複数のエクセルファイルあり
　フォルダ名：数字５桁のID番号と店舗名（11111_東京店）

・エクセルファイルには3シートあり、その中の特定のシートの表を
　別シートAの転記用の同じ内容の表に値で抽出
　エクセルファイル名⇒ID番号と書類名（11111_○○調査票）
　特定シートのシート名は全共通⇒『○○調査票』）

■やりたいこと
　転記する際、ファイルは開かない、
　keywordはIDで一致したら処理（別シートAでID検索で呼び出し）

以下のようにコードを書いたのですが、子フォルダのpathの指定やつなげ方で行き詰ってしまい、何か足りないのか教えていただけると助かります

Sub 調査票抽出()

    Dim path, fso, file, files
    Dim Wb As Workbook
    Dim LastRow_Wb As Long
    Dim Ws As Worksheet
    Dim i As Long

    Set Wb = ActiveWorkbook

    '読み取るブック格納先
    path = "C:\Users\nfujigaki\Desktop\○○\業務ツール\サンプル\"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files

    '貼り付け開始位置
    LastRow_Wb = 7

    Application.ScreenUpdating = False

        'フォルダ内の全ファイルについて処理
        For Each file In files

    'エクセルを不可視で開く
    ExcelApp.Visible = False  'エクセル可視/不可視設定
    ExcelApp.DisplayAlerts = False
    '警告メッセージをオフ
    Set Wb = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True)

    '読取り専用で開く
    '処理例
    '別ブックのセルの値を取得
    Debug.Print Wb.Worksheets("Sheet1").[A1].Value

    ExcelApp.DisplayAlerts = True   '警告メッセージをオン
    ExcelApp.Quit
    'Excel終了
    Set ExcelApp = Nothing
    '参照を解放

    Dim keyword As String
    keyword = Wb.Range("G3").Value
    keyword = Format(keyword, "00000")

    'IDが一致であれば処理をする

      If Format(Wb.Cells(y, 1).Value, "00000") = keyword Then
        If Wb.Cells(y, 1).Value <> "" Then
          i = 0
          For i = 1 To z
             Wb.Cells(x, i).Value = Ws.Cells(y, i).Value
          Next i
          x = x + 1
        End If

       End If

      y = y + 1

    Loop

        'シート名が「＊」だったら
            If Ws.Name = "調査票 " Then

        '1～最終行までループ
            For i = 1 To Ws.Cells(Rows.Count, 1).End(xlUp).Row

        '指定セルコピー
         Ws.Range(Cells(i, 7), Cells(i, 76)).Copy Wb.ActiveSheet.Cells(LastRow_Wb, 1)

        '貼り付け開始位置を変更
         LastRow_Wb = LastRow_Wb + 1

        'ジャンプ
                GoTo MyJump
            End If
        Next i
    End If
 Next Ws
MyJump:

        '開いたエクセルファイルを保存せず閉じる
          Application.DisplayAlerts = False
          ActiveWindow.Close
          Application.DisplayAlerts = True

        End If
      Next file

    Application.ScreenUpdating = True

End Sub

＜使用 Excel：unknown、使用 OS：unknown ＞

削除　最初の投稿を以下に訂正お願いします

『多階層のフォルダ内のファイルをIDで書き出して別シートに抽出』（こそら）
・親フォルダに複数の子フォルダがある
・子フォルダには複数のエクセルファイルあり
　フォルダ名：数字５桁のID番号と店舗名（11111_東京店）
・エクセルファイルには3シートあり、その中の特定のシートの表を
　別シートAの転記用の同じ内容の表に値で抽出
　エクセルファイル名⇒ID番号と書類名（11111_○○調査票）
　特定シートのシート名は全共通⇒『○○調査票』）
■やりたいこと
　転記する際、ファイルは開かない、
　keywordはIDで一致したら処理（別シートAでID検索で呼び出し）
以下のようにコードを書いたのですが、子フォルダのpathの指定やつなげ方で行き詰ってしまい、何か足りないのか教えていただけると助かります
Sub 調査票抽出()

    Dim path, fso, file, files
    Dim Wb As Workbook
    Dim LastRow_Wb As Long
    Dim Ws As Worksheet
    Dim i As Long
    Set Wb = ActiveWorkbook
    '読み取るブック格納先
    path = "C:\Users\○○○○\Desktop\○○\業務ツール\サンプル\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files
    '貼り付け開始位置
    LastRow_Wb = 7
    Application.ScreenUpdating = False
        'フォルダ内の全ファイルについて処理
        For Each file In files
    'エクセルを不可視で開く
    ExcelApp.Visible = False  'エクセル可視/不可視設定
    ExcelApp.DisplayAlerts = False
    '警告メッセージをオフ
    Set Wb = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True)
    '読取り専用で開く
    '処理例
    '別ブックのセルの値を取得
    Debug.Print Wb.Worksheets("Sheet1").[A1].Value
    ExcelApp.DisplayAlerts = True   '警告メッセージをオン
    ExcelApp.Quit
    'Excel終了
    Set ExcelApp = Nothing
    '参照を解放
    Dim keyword As String
    keyword = Wb.Range("G3").Value
    keyword = Format(keyword, "00000")
    'IDが一致であれば処理をする
      If Format(Wb.Cells(y, 1).Value, "00000") = keyword Then
        If Wb.Cells(y, 1).Value <> "" Then
          i = 0
          For i = 1 To z
             Wb.Cells(x, i).Value = Ws.Cells(y, i).Value
          Next i
          x = x + 1
        End If
       End If
      y = y + 1
    Loop
        'シート名が「＊」だったら
            If Ws.Name = "調査票 " Then
        '1～最終行までループ
            For i = 1 To Ws.Cells(Rows.Count, 1).End(xlUp).Row
        '指定セルコピー
         Ws.Range(Cells(i, 7), Cells(i, 76)).Copy Wb.ActiveSheet.Cells(LastRow_Wb, 1)
        '貼り付け開始位置を変更
         LastRow_Wb = LastRow_Wb + 1
        'ジャンプ
                GoTo MyJump
            End If
        Next i
    End If
 Next Ws
MyJump:
        '開いたエクセルファイルを保存せず閉じる
          Application.DisplayAlerts = False
          ActiveWindow.Close
          Application.DisplayAlerts = True
        End If
      Next file
    Application.ScreenUpdating = True
End Sub
＜ 使用 Excel：unknown、使用 OS：unknown ＞
（こそら） 2023/11/05(日) 12:47:42

書き溜めている間に追加投稿がありましたが、かいちゃったのでそのまま投稿します。

 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

よくわからない部分もありますが、何点か

■１
＞転記する際、ファイルは開かない
断言しませんが難しいと思います。（出来たとしてもかなり手間が増える）
開いた直後に最小化するなどで目立たなくすることはできますが、それではダメなんですか？

 ※ググると↓がヒットしましたが、コードの一部はそこを参考にされてますよね。多分
https://jovba.com/2022/12/29/other_books1/
否定はしませんが、採用されるならされるで何をやっているかちゃんと理解してからにされたほうが良いと思います。

■２
＞keywordはIDで一致したら処理（別シートAでID検索で呼び出し）
意味が理解できません。
具体的に、行・列を踏まえたレイアウトで、どういうときにどうなるのが正解なのか提示できませんか？

■３
＞フォルダ名：数字５桁のID番号と店舗名（11111_東京店）
＞子フォルダには複数のエクセルファイルあり
＞エクセルファイル名⇒ID番号と書類名（11111_○○調査票）
＞特定シートのシート名は全共通⇒『○○調査票』

↑が本当だとして、説明とコードが一致していません（さらに、末尾に半角スペース入っちゃってます）

 If Ws.Name = "調査票 " Then

■４
↓だとおかしい気がします。(私の勘違いだったらごめんなさい）

 Dim Wb As Workbook
 keyword = 【Wb】.Range("G3").Value
 If Format(【Wb】.Cells(y, 1).Value, "00000") = keyword Then
 If 【Wb】.Cells(y, 1).Value <> "" Then
 【Wb】.Cells(x, i).Value = Ws.Cells(y, i).Value

（もこな２） 2023/11/05(日) 13:13:27

少なくともコンパイルエラーが出ないものを提示し直してください。
（xyz） 2023/11/05(日) 13:42:43

もこな２さん、xyzさん、コメントの返信をありがとうございます

説明が足りなくてわかりにくくすみません
シートAにある表が用意してあり、複数ファイルから転記をした表と比較がしたいのです
比較をするためにファイルを開きながらの作業がとても大変なので、なんとか抽出だけでも自動化できないかというのが目的です

業務上、親フォルダも1000件くらいあり、子フォルダにも複数ファイルが同じくらいあるため、IDで紐づけてなんとかできないかと思いました、現在の社内環境でできることを模索しているしだいです

■１
　そちらのサイトではなく、社内で似たようなケースの処理があり別の人が開発したツールで教えて
　もらったコードを使用しています
　サイトの内容も参考にさせていただきます
　最小化で時間がかからないのであれば表示する方法でも問題ないです

■2
シートAレイアウトについてサンプルがこちらに貼付できないようなので説明になります

シートAには比較する表と転記する表がそれぞれあり
抽出する表の範囲はB2:V76
転記する表の貼付け範囲はJ7：AD74です

■3　
半角スペースについて、ご指摘ありがとうございます
ほんとですね…

■4
もう少し考えてみます

まだVBAを勉強し始めたばかりでよくわからない点も多いのですが、仕事で急を要しており質問させていただきました。ありがとうございました

（こそら） 2023/11/05(日) 18:42:02

 バージョンが以降なら、抽出にはPower Queryがおすすめです。

（マナ） 2023/11/05(日) 18:55:55

Power Query案もあるようなので、そちらで行くなら↓は無視してください。

■５
＞社内で似たようなケースの処理があり別の人が開発したツールで教えてもらったコードを使用しています
そうですか。いずれにせよ、採用されなら仕組みをちゃんと理解してからにすべきだと思います。

＞最小化で時間がかからないのであれば表示する方法でも問題ないです
ご自身で判断してください。
（個人的にはわからないものを時間をかけるより、分かる方法でとりあえず完成させてから改良していくのがいいじゃないかとおもいます）

■６
＞シートAには比較する表と転記する表がそれぞれあり
＞抽出する表の範囲はB2:V76
＞転記する表の貼付け範囲はJ7：AD74です
残念ながら理解できません。

■７
＞半角スペース～
そこは、オマケの指定です。
こちらの意図としては↓じゃないかと言っています。

 誤 If Ws.Name = "調査票" Then
 正 If Ws.Name Like= "*調査票" Then

■８
＞もう少し考えてみます
考えるほど難しいことを言っているつもりはありません。
１つのブックは↓みたいな構造ですから

 Workbookオブジェクト
  └Worksheetオブジェクト
 　　└Rangeオブジェクト

↓のように「ブックのセル」ではなく、「ブックの【どのシートの】どのセル」という指定で無いとおかしいと言っています。

 誤 Wb.Range("G3").Value
 正 wb.Worksheet("○○調査票").Range("G3").Value

■９
＞仕事で急を要しており～
「■５」とも関連しますが、急ぐならなおさら、別インスタンスのExcelで開くというあまり見かけない処理より

 1. 対象のブックを開く
 2. 必要なデータを【抽出】する
 3. 抽出したデータをコピペする
 4. ブックを閉じる

というアプローチでとりあえず作成しておき、時間に余裕ができてから、いろいろ試されたほうがいいんじゃないかと思いました。（私見ですが）

（もこな２） 2023/11/05(日) 20:30:51

コメント返信：

[ 一覧(最新更新順) ]

[[20231105104611]] 『多階層のフォルダ内のファイルをIDで書き出して別』（こそら） ページの最後に飛ぶ

[[20231105104611]]　『多階層のフォルダ内のファイルをIDで書き出して別』（こそら）　ページの最後に飛ぶ