Un Known…(跡地) 技術メモ

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