Excelシートのデータを抽出する

データ抽出.vbs

Option Explicit


' |              |         |          |cell_name1|cell_name2|...
' |directory_name|book_name|sheet_name|
'

Public Sub データ抽出()
    Dim ブック_オリジナル As Workbook: Set ブック_オリジナル = ThisWorkbook
    Dim シート_オリジナル As Worksheet: Set シート_オリジナル = ブック_オリジナル.Sheets(1)
    Dim ブック_出力 As Workbook
    Dim シート_出力 As Worksheet
    
    Set ブック_出力 = Workbooks.Add
    ' オリジナルのシートを、出力ブックの先頭にコピー
    シート_オリジナル.Copy Before:=ブック_出力.Sheets(1)
    Set シート_出力 = ブック_出力.Sheets("Sheet1 (2)")

    Call 読込ループ(シート_出力)

End Sub

Private Sub 読込ループ(ByRef シート_出力 As Worksheet)
    On Error GoTo エラー_読込:
    
    Const 行_読込セル定義 As Integer = 3
    Const 行_開始 As Integer = 4
    Const 列_パス名 As Integer = 1
    Const 列_ブック名 As Integer = 2
    Const 列_シート名 As Integer = 3
    Const 列_読込結果 As Integer = 5
    Const 列_開始 As Integer = 6

    Dim nRow As Integer: nRow = 行_開始
    シート_出力.Cells(nRow, 列_パス名).Select
    Do While シート_出力.Cells(nRow, 列_パス名) <> ""
        Dim sPath As String: sPath = シート_出力.Cells(nRow, 列_パス名)
        Dim sBook As String: sBook = シート_出力.Cells(nRow, 列_ブック名)
        Dim sSheet As String: sSheet = シート_出力.Cells(nRow, 列_シート名)
        
        Dim ファイルSys As Object: Set ファイルSys = CreateObject("Scripting.FileSystemObject")
        If ファイルSys.FileExists(sPath & "\" & sBook) = True Then
            Dim ブック_読込 As Workbook: Set ブック_読込 = Workbooks.Open(Filename:=sPath & "\" & sBook, ReadOnly:=True)
            Dim シート_読込 As Worksheet: Set シート_読込 = ブック_読込.Worksheets(sSheet)

            Dim nCol As Integer: nCol = 列_開始
            Do While シート_出力.Cells(行_読込セル定義, nCol) <> ""
                Dim セル名 As String: セル名 = シート_出力.Cells(行_読込セル定義, nCol)
        
                シート_出力.Cells(nRow, nCol) = シート_読込.Range(セル名)
            
                nCol = nCol + 1
            Loop

            ブック_読込.Close
            シート_出力.Cells(nRow, 列_読込結果) = "OK"
        
        Else
            シート_出力.Cells(nRow, 列_読込結果) = "ファイルが存在しません"
        End If
        
        GoTo 次の行
エラー_読込:
        シート_出力.Cells(nRow, 列_読込結果) = Err.Description
次の行:
        nRow = nRow + 1
    Loop

End Sub