Data extraction from from multiple excel books.

データ抽出.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
            シート_出力.Cells(nRow, 列_読込結果) = "ファイルが存在しません"
        Else
            Dim ブック_読込 As Workbook: Set ブック_読込 = Workbooks.Open(Filename:=sPath & "\" & sBook, ReadOnly:=True)
            
            If シート存在チェック(ブック_読込, sSheet) <> True Then
                シート_出力.Cells(nRow, 列_読込結果) = "シートが存在しません"
                ブック_読込.Close
            Else
            
                Dim シート_読込 As Worksheet: Set シート_読込 = ブック_読込.Worksheets(sSheet)

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

                ブック_読込.Close
                シート_出力.Cells(nRow, 列_読込結果) = "OK"
            End If

        End If
        
        GoTo 次の行
エラー_読込:
        シート_出力.Cells(nRow, 列_読込結果) = Err.Description
次の行:
        nRow = nRow + 1
    Loop

End Sub

Function シート存在チェック(ブック As Workbook, シート名 As String)
    Dim ws As Worksheet, flag As Boolean
    If ブック Is Nothing Then
        シート存在チェック = False
        Exit Function
    End If
    
    For Each ws In ブック.Worksheets
        If ws.Name = シート名 Then flag = True
    Next ws
    If flag = True Then
        シート存在チェック = True
    Else
        シート存在チェック = False
    End If
End Function