VBA pickout data on excel sheets in folder

目的

次のようなexcel sheetから黄色セルのデータを抜き出したい時のVBAのsampleの１例を示す。

 1. コマンドにexcel fileの保管場所を入力するセルを用意する。

以下のように実行するためのボタンを挿入する。
黄色のセルは２のVBAで読み込む。

2. VBAを起動（ Alt + F11)し、以下のコードを標準モジュールに張り付ける。

Sub ボタン1_Click()
    Dim commandSheet As Worksheet
    Set commandSheet = ThisWorkbook.Worksheets(1)
    Dim dstSheet As Worksheet
    If (ThisWorkbook.Worksheets.Count = 1) Then
        ThisWorkbook.Worksheets.Add(after:=Worksheets(1), Count:=1).Name = "結果"
    End If
    Set dstSheet = ThisWorkbook.Worksheets(2) 'Data will be printed at 2'nd sheet

    Dim Path As String
    Path = commandSheet.Cells(3, 3)
    Dim buf As String
    buf = Dir(ActiveWorkbook.Path & Path & "*.xlsx")

    Dim i As Long 'for workbooks
    Dim j As Long 'for sheets
    Dim k As Long 'for printlines
    Dim bPrintHeader As Boolean
    bPrintHeader = False
    k = 2 ' first line of data

    Do While buf <> ""
        i = i + 1
        DoEvents
        Dim srcBook As Workbook
        Set srcBook = Workbooks.Open(ActiveWorkbook.Path & Path + buf)
        Dim srcSheet As Worksheet
        Dim sheetname As String
        For j = 1 To srcBook.Worksheets.Count
            Set srcSheet = srcBook.Worksheets(j)
            sheetname = srcSheet.Name
            If (InStr(sheetname, "履歴") = 0) Then
                If (bPrintHeader = False) Then
                    dstSheet.Cells(1, 1).Value = "FileName(Specification)"
                    dstSheet.Cells(1, 2).Value = "Sheet Name"
                    dstSheet.Cells(1, 3).Value = "System Name"
                    dstSheet.Cells(1, 4).Value = "FileName(Logical)"
                    dstSheet.Cells(1, 5).Value = "Interface Name"
                    dstSheet.Cells(1, 6).Value = "FileName(Physical)"
                    dstSheet.Cells(1, 7).Value = "CharacterSet"
                    bPrintHeader = True
                End If
                dstSheet.Cells(k, 1).Value = buf 'FileName
                dstSheet.Cells(k, 2).Value = sheetname 'Sheet Name
                dstSheet.Cells(k, 3).Value = srcSheet.Cells(2, "C") 'System Name
                dstSheet.Cells(k, 4).Value = srcSheet.Cells(3, "C") 'FileName(Logical)
                dstSheet.Cells(k, 5).Value = srcSheet.Cells(3, "E") 'Interface Name
                dstSheet.Cells(k, 6).Value = srcSheet.Cells(4, "C") 'FileName(Physical)
                dstSheet.Cells(k, 7).Value = srcSheet.Cells(4, "E") 'CharacterSet
                k = k + 1
            End If
        Next
        srcBook.Close False
        buf = Dir()
    Loop
    MsgBox "Completed"
    Exit Sub
End Sub

3. 結果