複数のExcelブックから特定シートのセル範囲抽出

質問

同一フォルダ内にある複数のExcelブックから特定シートの特定セル範囲を抽出して一覧表にまとめるExcel マクロ（VBA）を教えてください。
このサイトで殆どよく似た回答を読んだのですがうまくいきません。VBA初心者です。
よろしくお願いします。
【前提】
・実行する端末のOSはWindows 10　ExcelはＯｆｆｉｃｅ365　ＰｒｏＰｌｕｓ
・対象フォルダはネットワーク接続フォルダ
　この中に、複数のExcelブック（ｘｌｓｘ、ｘｌｓｍ）があります。
・抽出したい対象は、各ブック内の「台帳」シートの「Ａ3：Cの最終行」で
　複数のブックの中には「台帳」シートが含まれていないブックも混在しています。

【抽出一覧作成イメージ】
・「集約.xlsm」ブックの「集計」シートの２行目から抽出した結果を一覧表示する。
・「集約.xlsm」ブックにマクロは登録する
・表示はA列に抽出元ブック名（＝ファイル名）、B列からD列に抽出元「Ａ3：Cの最終行」セルの値。
・「Ａ3：Cの最終行」セルの値を「集約.xlsm」ブックの「集計」に貼り付ける際には「値で貼り付ける」が望ましい。

回答No.4

SI299792 · ベストアンサー

あなたが補足に上げたプログラムの問題点ですが。
・Dir(PName & "*親プロジェクト*.xls*")
　にして拡張子を付けないと認識しない。
・集計最終行 = Cells(Rows.Count, 1).End(xlUp).Row + 1
　がループの外にあるので、全てのファイルがこの場所に転記される。下へ転記されないかない。
・台帳シートが存在しない場合の処理がない。
・PasteSpecialはPaste 先がアクティブである必要がある。
　ThisWorkbook.Activtate　を入れればよい。
・ファイル名を入れていない。
これらを踏まえてプログラムを直してみて下さい。

別のやり方をしたものを載せます。
質問では「A3:Cの最終行」セルの値。になっていますが、
プログラムでは、A8:Iの最終行になっています。
質問の方を信じました。

Option Explicit
'
Sub Macro1()
　　Const PathName = "D:\Test"
　　Dim FileName As String
　　Dim RInp As Long
　　Dim IBook As Workbook
　　Dim IRange As Range
　　Dim WkInt As Integer
'
　　Sheets("Sheet1").Select
　　FileName = Dir(PathName & "\*親プロジェクト*.xls*")
　　RInp = 2
'
　　While FileName > ""
　　　　Set IBook = Workbooks.Open(PathName & "\" & FileName, False, True)
　　　　On Error Resume Next
　　　　Sheets("台帳").Select
　　　　WkInt = Err
　　　　On Error GoTo 0
'
　　　　If WkInt = 0 Then
　　　　　　Set IRange = Cells(Rows.Count, "A").End(xlUp)
　　　　　　Set IRange = Range("C3", IRange)
　　　　　　ThisWorkbook.Activate
　　　　　　WkInt = InStr(FileName, ".") - 1
　　　　　　Cells(RInp, "A").Resize(IRange.Rows.Count) = Left(FileName, WkInt)
　　　　　　Cells(RInp, "B").Resize(IRange.Rows.Count, 3) = IRange.Value
　　　　　　RInp = RInp + IRange.Rows.Count
　　　　End If
　　　　IBook.Close False
　　　　FileName = Dir
　　Wend
　　MsgBox "終了しました"
End Sub

お礼

ご指摘内容を修正したら動くようになりました。
ただ『Dir(PName & "*親プロジェクト*.xls*")　にして拡張子を付けないと認識しない』件ですが拡張子なしでも
動いてしまいました。何か問題があるかもしれませんが・・
あと『台帳シートが存在しない場合の処理がない』は考慮に入っていませんでした。
ご回答通りの記述は簡潔で完璧でした。
助かりました。
本当にありがとうござました。

回答No.3

masnoske

[No.2] の補足です．
モジュールの外で Option Explicit を宣言しておくと，必ず変数を宣言しないと使えないようにできます．
これを宣言した状態でデバッグすれば，台帳FName が宣言されていない変数であるとエラー表示されますので，この手のミスを発見できます，
毎回宣言するのは面倒なので，以下のサイトを参考にエディタに設定しておくのが良いでしょう．
http://officetanaka.net/excel/vba/beginner/11.htm

回答No.2

masnoske

台帳FName = Dir()　の記述が間違っていますよ．
FName = Dir()　です．

お礼

回答ありがとうございました。
FName = Dir()に修正しオプションの「変数の宣言を強制する（R)」にチェックを入れましたが
結果的にマクロを実行すると最後まで終了するのですが集計データは１ファイル分のみの結果
しか出力されませんでした。
原因を確認したくステップイン（F8）で行うと
『 Workbooks(台帳FName).Close savechanges:=False』の行で以下の画面が出て止まってし
まいました。

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim chkBox As Excel.CheckBox
Application.ScreenUpdating = False
For Each chkBox In ActiveSheet.CheckBoxes
chkBox.Value = xlOff
Next chkBox
Application.ScreenUpdating = True
End Sub

やはりマクロの記述が間違っているのでしょうか？
何度もすみませんがよろしくお願いします。

補足

すみません　内容が間違っておりました
【誤り】結果的にマクロを実行すると最後まで終了するのですが集計データは
　　　　１ファイル分のみの結果しか出力されませんでした。

【正】結果的にマクロを実行すると最後まで終了するのですが集計データは
　　　　最後のファイルがA1から上書きされていました。
　　　　１ファイル目　150行
　　　　 2ファイル目 50行
　　　　 3ファイル目 550行
　　　 　4ファイル目 　30行
で出力結果は４ファイル目の30行＋３ファイル目の31行~550行でした
　　　　多分すべてのファイルデータが集計デーダのA1から繰り返し貼付けられていたようでした。
　　　集計データの最終行に次のファイルデータを貼付ける記述がうまくいっていないようです。

回答No.1

masnoske

VBA初心者ということなので，まずは作業を具体化し，それが確実に動くことを確認してから次のステップに移るというプログラミングの基本から覚えましょう．

>・対象フォルダはネットワーク接続フォルダ
> この中に、複数のExcelブック（ｘｌｓｘ、ｘｌｓｍ）があります。

まずは，以下の部分をプログラミングしてみてください．
「ネットワークフォルダにあるExcelブックを順次開いて，閉じる．」
MsgBox や Debug.Print で動作を確認すれば良いでしょう．

今回の問題で初心者にとって最も難しいのは，上記のマクロ記録でカバーできない部分です．
VBA Dir　といったキーワードで検索すれば，答えが見つかると思います．

もしも「台帳」シートが含まれるブックと含まれないブックをファイル名で区別できるなら，処理が簡単になります．
ファイル名のルールを決めて区別できるようにするか，処理対象のファイルは決められたフォルダに保存するようにルール化します．これはマクロ化以前の問題なので，マクロ化よりも先に検討すべき事です．

以上ができれば，残りの処理はブックを開く処理と閉じる処理の間に記述するだけですが，マクロの記録で対応できます．

「Ａ3：Cの最終行」の部分は，
VBA 最終行　といったキーワードで検索してみてください．
VBA を使うなら，暗記しておくような基本コードです．

お礼

ご回答ありがとございます。
ファイル名で「台帳」シートがあるかどうかは区別できると思います。
一度試してみます。

補足

「集約.xlsm」ブックにマクロを登録し以下のように記述してみましたが１ファイル目
のデータ貼付けの後『Workbooks(FName).Close savechanges:=False』の
記述で動かなくなってしまいました。
フォルダ内のファイルの特定はブック名の途中に『親プロジェクト』という文字が
入っているものを選択しようとしています。
このブックには必ず「台帳」シートが含まれております。
『集約.ｘｌｓｍ』マクロブックの「集計」シートにデータを集めたいです。
よろしくお願いします。

Sub macro12()
Dim PName As String
Dim FName As String
PName = "C:\Users\1111\Desktop\▲\"
FName = Dir(PName & "*親プロジェクト*")
Dim 集計最終行 As Long
集計最終行 = Cells(Rows.Count, 1).End(xlUp).Row + 1 '---マクロの最終行数+1
Do Until FName = ""
Workbooks.Open Filename:=PName & FName
Sheets("台帳").Select
Dim 台帳最終行 As Long
台帳最終行 = Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & 8 & ":I" & 台帳最終行).Copy
ThisWorkbook.Worksheets("集計").Cells(集計最終行, 1).PasteSpecial _
xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Workbooks(FName).Close savechanges:=False
台帳FName = Dir()
Loop
End Sub