Dir関数を用いるため、ネットワーク上の長いファイルパスには未対応です。
Sub Test() ' ' Test Macro ' ' フォルダ内のファイルに対して処理を行います。 ' ' 画面チラつきを防止する。 Application.ScreenUpdating = False ' フォルダパスとファイル名を宣言する。 Dim strFilePath As String Dim strFileNmae As String ' テキストボックスかセル入力でフォルダを指定させる。 strFilePath = "C:\Users\test\Desktop\テストディレクトリ" strFilePath = Worksheets("sheet1").Cells(2, 1).Value ' 末尾が\ではない場合、\を追加する。(未実装) strFilePath = strFilePath & "\" ' 指定フォルダ内のファイル名を取得する。 strFileName = Dir(strFilePath, vbNormal) ' 結果シートをアクティブにする。 Worksheets("sheet1").Activate ' 結果シートの行数を宣言する。 Dim longGyo As Long longGyo = 3 ' 指定フォルダ内のファイルがなくなるまで繰り返す。 Do While strFileName <> "" ' 結果配列とシート数を宣言する。 Dim strArr() As String Dim sheetCnt As Long ' ファイルを開く。 With Workbooks.Open(Filename:=strFilePath & strFileName) ' ファイル内のシート数を取得する。 sheetCnt = .Worksheets.Count ' ファイル内のシート数分+チェックしたい項目数分の2次元配列を確保する。 ReDim strArr(1 To sheetCnt + 1, 10) ' 1シート目からnシート目まで繰り返す。 Dim i As Long For i = 1 To sheetCnt strArr(i, 0) = .Worksheets(i).Name strArr(i, 1) = .Worksheets(i).Cells(3, 4).Value strArr(i, 2) = .Worksheets(i).PageSetup.LeftHeader strArr(i, 3) = .Worksheets(i).PageSetup.CenterHeader strArr(i, 4) = .Worksheets(i).PageSetup.RightHeader strArr(i, 5) = .Worksheets(i).PageSetup.LeftFooter strArr(i, 6) = .Worksheets(i).PageSetup.CenterFooter strArr(i, 7) = .Worksheets(i).PageSetup.RightFooter .Worksheets(i).Select strArr(i, 8) = ActiveWindow.Zoom strArr(i, 9) = ActiveCell.Address Next i ' 保存せずファイルを閉じる。 .Close SaveChanges:=False End With ' 配列の1からnまで繰り返す。 Dim j As Long For j = 1 To sheetCnt ' 結果シートのセルに各ファイルの各シートの値を設定する。 Cells(longGyo, 1).Value = strFilePath & strFileName Cells(longGyo, 2).Value = strArr(j, 0) Cells(longGyo, 3).Value = strArr(j, 1) Cells(longGyo, 4).Value = strArr(j, 2) Cells(longGyo, 5).Value = strArr(j, 3) Cells(longGyo, 6).Value = strArr(j, 4) Cells(longGyo, 7).Value = strArr(j, 5) Cells(longGyo, 8).Value = strArr(j, 6) Cells(longGyo, 9).Value = strArr(j, 7) Cells(longGyo, 10).Value = strArr(j, 8) Cells(longGyo, 11).Value = strArr(j, 9) longGyo = longGyo + 1 Next j ' 次のファイルを取得する。 strFileName = Dir() Loop ' 画面チラつき防止を解除する。 Application.ScreenUpdating = True End Sub