[[20201206230649]]　『フォルダ内の全シートデータ集計』（山口）　ページの最後に飛ぶ

『フォルダ内の全シートデータ集計』（山口）

フォルダ内の全シートの指定セルデータを集計したいのですが、各ブックの左シートまではできました。
全シートのデータを取得する場合はどのようにしたらよいのでしょうか？

Sub テスト()

    Dim DirPath As String   '自分のブックのディレクトリPathの変数
    Dim acWb As Workbook  '自分のワークブック用変数
    Dim acWbName As String   '自分のワークブックの名前用変数
    Dim acWs As Worksheet   '自分のワークシート用変数
    Dim FileSysObj As Object   'ファイルシステムオブジェクトの変数
    Dim FileObj As Object  'フォルダ内のブックの変数
    Dim acFileObj As Object  'アクティブなブック
    Dim acFileObjName As String  'アクティブなブックの名前
    Dim wb As Workbook  '順番に開いていくワークブック変数
    Dim ws As Worksheet  'wbのシート変数
    Dim row As Integer  '行

    Set acWb = ThisWorkbook  '自分のブックをセットする
    Set acWs = acWb.Sheets("集計")  '自分のブックの集計用ワークシートをセットする

    DirPath = acWb.path  '自分のブックのディレクトリを変数に代入
    acWbName = acWb.Name  '自分のブック名を変数に代入

    Set FileSysObj = CreateObject("Scripting.FileSystemObject")   'ファイルシステムオブジェクトのセット
    Set FileObj = FileSysObj.GetFolder(DirPath).Files   'フォルダ内のファイルのセット

   row = 1

    For Each acFileObj In FileObj

        acFileObjName = acFileObj.Name

       If InStr(acFileObjName, acWbName) Then  'ブック名が自分のブック名と同じ時は何もしない

        Else

            Workbooks.Open DirPath & "\" & acFileObjName

            Set wb = Workbooks(acFileObjName)
            Set ws = wb.Worksheets(1)

            acWs.Range("A" & row).Value = ws.Range("A4:B4").Value
            acWs.Range("B" & row).Value = ws.Range("C4:E4").Value
            acWs.Range("C" & row).Value = ws.Range("F24").Value

            row = row + 1

            wb.Close

        End If

    Next

    Set acFileObj = Nothing
    Set FileObj = Nothing
    Set FileSysObj = Nothing

End Sub

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

 for each ws in wb.worksheets

（マナ） 2020/12/06(日) 23:16

既に正答の提示がありますが私も参加で。

まず、好みにもよりますが提示のコードをちょっと整理してみるとこんな感じになります。

    Sub 整理()
        Dim row As Long
        Dim acFileObj As Object
        Dim acWs As Worksheet, ws As Worksheet
        Set acWs = ThisWorkbook.Sheets("集計")

        row = 1

        For Each acFileObj In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
            If acFileObj.Name <> ThisWorkbook.Name Then

                With Workbooks.Open(acFileObj.Path)
                    Set ws = .Worksheets(1) '★ここで１番目のシートを指定している

                    ThisWorkbook.Sheets("集計").Cells(row, "A").Value = ws.Range("A4").Value
                    ThisWorkbook.Sheets("集計").Cells(row, "B").Value = ws.Range("C4").Value
                    ThisWorkbook.Sheets("集計").Cells(row, "C").Value = ws.Range("F24").Value

                    row = row + 1
                    .Close
                End With
            End If
        Next acFileObj

    End Sub

このように整理してみると★のところが、1番目のシートで固定ではなく、2番目や３番目のシートに次々入れ替われば良さそうだとわかりますよね。
そこを、マナさんがアドバイスされているような「For each ～ Nextステートメント」や、以下に示すような「For ～ Nextステートメント」を使って、各々のシートを対象に処理するように改造してやればよいです。

    Sub 整理_改()
        Dim row As Long
        Dim acFileObj As Object
        Dim acWs As Worksheet, ws As Worksheet
        Dim i As Long
        Set acWs = ThisWorkbook.Sheets("集計")

        Stop 'ブレークポイントの代わり
        row = 1

        For Each acFileObj In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
            If acFileObj.Name <> ThisWorkbook.Name Then

                With Workbooks.Open(acFileObj.Path)
                    For i = 1 To .Worksheets.Count '1～最後のシートまで順番に処理
                        Set ws = .Worksheets(i) '★「i」番目のシートをセット

                        ThisWorkbook.Sheets("集計").Cells(row, "A").Value = .Name
                        ThisWorkbook.Sheets("集計").Cells(row, "B").Value = ws.Name
                        ThisWorkbook.Sheets("集計").Cells(row, "C").Value = ws.Range("A4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "D").Value = ws.Range("C4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "E").Value = ws.Range("F24").Value

                        row = row + 1
                    Next i
                    .Close
                End With
            End If
        Next acFileObj

    End Sub

（もこな２） 2020/12/07(月) 16:31

マナさん、もこなさん
本当にありがとうこざいます！
まだVBAを始めたばかりなので、とても勉強になります。
（山口） 2020/12/09(水) 07:13

With Workbooks.Open(acFileObj.Path)
の部分でエラーになります。

ファイル形式またはファイル拡張子が正しくありません、というエラーです。
何が原因なのでしょうか？
（山口） 2020/12/09(水) 12:01

エラーになるとき、【acFileObj.Path】は、どうなるのでしょうか？
当たり前ですが、手作業でエクセルで開けないものは、マクロでも開けないですよ。

（もこな２） 2020/12/09(水) 12:25

もこなさん、ありがとうございます。

上記コードをテストというエクセルに記述していて、
エラーコメントで「エクセルファイルの"＄テスト.xlsm"を開けません」
となります。

アドバイスお願いします。
（山口） 2020/12/09(水) 15:54

繰り返しになりますが、エラーになるとき、【acFileObj.Path】は、どうなるのでしょうか？
エラーメッセージから推測して、それはゴミファイルを開こうとして失敗しているようにおもいますが…

（もこな２） 2020/12/09(水) 21:23

 If Not acFileObj.Name Like "~$*" Then

を追加してください。
ところで、対象ブックは、.xlsxでなく、.xlsmなのでしょうか？

（マナ） 2020/12/09(水) 21:35

もこなさん
知識不足でエラーになる時の【acFileObj.Path】がどうなってるか分からなかったです。
申し訳ありません。
テストというエクセルを開いて、マクロを実行して、テストが開けませんとなっていました。

マナさん
ありがとうございます。
If Not acFileObj.Name Like "~$*" Thenを記述する場所は、
If acFileObj.Name <> ThisWorkbook.Name Thenの次で良いのでしょうか？
（山口） 2020/12/09(水) 22:45

＞知識不足でエラーになる時の【acFileObj.Path】がどうなってるか分からなかったです。
ステップ実行して調べてみましたか？

方法はいくつかあるとおもいますが、例えばエラー時にイミディエイトに「?acFileObj.Path」と入力することでも調べられると思いますよ。

（もこな２） 2020/12/09(水) 23:32

＞次で良いのでしょうか？

はい。

（マナ） 2020/12/10(木) 12:25

もこなさん
エラー時にイミディエイトに入力する、そういう事を初めて知りました。
もっと勉強します。
ありがとうございます。

マナさん
出来ました！
ありがとうございます。
（山口） 2020/12/10(木) 14:07

質問者さんへ

勉強のために勝手にしていることなので無視してください。

今回のことをPower Queryでしようとすると、こんな感じ
（自ブックと同じフォルダ内のブックの指定セルの値を取り込む例）

 １）作業用シートを追加（非表示でもよい）
 ２）A1：自ブック
 　　A2：=CELL("filename",A1)
 　　A3：=MID(A2,1,FIND("[",A2)-1)
 　　A4：=MID(A2,FIND("[",A2)+1,LEN(A2)-FIND("]",A2)+1)
 ３）テーブルに変換し、テーブル名を「自ブック」に変更

 '----
 let
    対象フォルダ = Excel.CurrentWorkbook(){[Name="自ブック"]}[Content]{1}[自ブック],
    自ブック名 = Excel.CurrentWorkbook(){[Name="自ブック"]}[Content]{2}[自ブック],	
    ソース = Folder.Files(対象フォルダ),
    #"展開された Attributes" = Table.ExpandRecordColumn(ソース, "Attributes", {"Hidden"}, {"Hidden"}),
    小文字テキスト = Table.TransformColumns(#"展開された Attributes",{{"Extension", Text.Lower, type text}}),
    フィルターされた行 = Table.SelectRows(小文字テキスト, each [Extension] = ".xlsm" or [Extension] = ".xlsx" and [Name] <> 自ブック名 and [Hidden] <> true),
    追加されたカスタム = Table.AddColumn(フィルターされた行, "カスタム", each Excel.Workbook(File.Contents(対象フォルダ & [Name]))),
    #"展開された カスタム" = Table.ExpandTableColumn(追加されたカスタム, "カスタム", {"Data", "Item"}, {"Data", "Item"}),
    削除された他の列 = Table.SelectColumns(#"展開された カスタム",{"Name", "Item", "Data"}),
    #"名前が変更された列 " = Table.RenameColumns(削除された他の列,{{"Name", "ブック"}, {"Item", "シート"}}),
    追加されたカスタム1 = Table.AddColumn(#"名前が変更された列 ", "A4", each [Data]{3}[Column1]),
    追加されたカスタム2 = Table.AddColumn(追加されたカスタム1, "C4", each [Data]{3}[Column3]),
    追加されたカスタム3 = Table.AddColumn(追加されたカスタム2, "F24", each [Data]{23}[Column6]),
    削除された列 = Table.RemoveColumns(追加されたカスタム3,{"Data"})
 in
    削除された列

 '----

 課題：
 取り込むシートの１行目が空白行でないことが前提
 空白行でも１行目から取り込む方法がわかりません

（マナ） 2020/12/10(木) 19:05

マナさん、すごすきます！
（山口） 2020/12/12(土) 10:11

下記のように同じフォルダ内での指定はできました。
例えば、同じフォルダではなくダイアログボックスを出して
ディレクトリを指定する場合はどのようにコードを変更すればよいのでしょうか？

Private Sub CommandButton1_Click()

        Dim row As Long
        Dim acFileObj As Object
        Dim acWs As Worksheet, ws As Worksheet
        Dim i As Long

        row = 1
        For Each acFileObj In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
            If acFileObj.Name <> ThisWorkbook.Name Then
            If Not acFileObj.Name Like "~$*" Then
                With Workbooks.Open(acFileObj.Path)
                    For i = 1 To .Worksheets.Count '1～最後のシートまで順番に処理
                        Set ws = .Worksheets(i) '★「i」番目のシートをセット
                        ThisWorkbook.Sheets("集計").Cells(row, "A").Value = .Name
                        ThisWorkbook.Sheets("集計").Cells(row, "B").Value = ws.Name
                        ThisWorkbook.Sheets("集計").Cells(row, "C").Value = ws.Range("H4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "D").Value = ws.Range("A4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "E").Value = ws.Range("C4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "F").Value = ws.Range("G24").Value
                        row = row + 1
                    Next i
                    .Close
                End With
            End If
            End If
        Next acFileObj

End Sub

（山口） 2020/12/12(土) 10:14

下記コードは検索したら出てきましたが、どのように使えばいいか分かりません。

With Application.FileDialog(msoFileDialogFolderPicker)

        If .Show = True Then
            buf = .SelectedItems(1)
            xlsxFile = Dir(buf & "\*.xlsx")
        End If
End With
（山口） 2020/12/12(土) 10:34

＞下記コードは検索したら出てきましたが、どのように使えばいいか分かりません
まずはステップ実行して、「buf」に何が入るか研究してみてはどうですか？

（もこな２） 2020/12/12(土) 10:41

もこなさん
ステップ実行したら、bufには指定したディレクトリが入っていました。
（山口） 2020/12/12(土) 10:48

下記コードで指定ディレクトリのエクセルを集計できました。
ただxlsxファイルだけにはなりませんでした。

xlsxFile を使えるよう考えてみます。

Sub Macro2()

        Dim row As Long
        Dim buf As String
        Dim xlsxFile As String
        Dim acFileObj As Object
        Dim acWs As Worksheet, ws As Worksheet
        Dim i As Long
        Set acWs = ThisWorkbook.Sheets("集計")

        With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            buf = .SelectedItems(1)
            xlsxFile = Dir(buf & "\*.xlsx")
        End If
       End With

        row = 1
        For Each acFileObj In CreateObject("Scripting.FileSystemObject").GetFolder(buf).Files
            If acFileObj.Name <> ThisWorkbook.Name Then
            If Not acFileObj.Name Like "~$*" Then
                With Workbooks.Open(acFileObj.Path)
                    For i = 1 To .Worksheets.Count '1～最後のシートまで順番に処理
                        Set ws = .Worksheets(i) '★「i」番目のシートをセット
                        ThisWorkbook.Sheets("集計").Cells(row, "A").Value = .Name
                        ThisWorkbook.Sheets("集計").Cells(row, "B").Value = ws.Name
                        ThisWorkbook.Sheets("集計").Cells(row, "C").Value = ws.Range("H4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "D").Value = ws.Range("A4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "E").Value = ws.Range("C4").Value
                        ThisWorkbook.Sheets("集計").Cells(row, "F").Value = ws.Range("G24").Value
                        row = row + 1
                    Next i
                    .Close
                End With
            End If
            End If
        Next acFileObj

End Sub
（山口） 2020/12/12(土) 11:00

コメント返信：

[ 一覧(最新更新順) ]

[[20201206230649]] 『フォルダ内の全シートデータ集計』（山口） ページの最後に飛ぶ

[[20201206230649]]　『フォルダ内の全シートデータ集計』（山口）　ページの最後に飛ぶ