データ抽出と強調表示を同時に行う

データ抽出_強調表示.vbs

Option Explicit

Private Const 強調色 = 4



' |              |         |          |cell_name1|cell_name2|...
' |directory_name|password|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)")

    Application.DisplayAlerts = False

    Call 読込ループ(シート_出力)
    
    Application.DisplayAlerts = True

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 = 4
    Const 列_読込結果 As Integer = 6
    Const 列_開始 As Integer = 7

    Dim nRow As Integer: nRow = 行_開始
    シート_出力.Cells(nRow, 列_パス名).Select
    Do While シート_出力.Cells(nRow, 列_パス名) <> ""
        Dim sPath As String: sPath = シート_出力.Cells(nRow, 列_パス名)
        Dim sPasswd As String: sPasswd = シート_出力.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, Password:=sPasswd)
            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
        Resume 次の行
次の行:
        nRow = nRow + 1
    Loop

    Call 強調(シート_出力, 行_読込セル定義, 行_開始, 列_開始, 列_パス名)
    
End Sub

Private Sub 強調(ByRef シート_出力 As Worksheet, 行_読込セル定義 As Integer, 行_開始 As Integer, 列_開始 As Integer, 列_パス名 As Integer)
    Dim 列_検索最終 As Integer: 列_検索最終 = シート_出力.Cells(行_読込セル定義, 列_開始).End(xlToRight).Column

    Dim r As Range:  Set r = Range(シート_出力.Cells(行_開始, 列_パス名), シート_出力.Cells(行_開始, 列_パス名).End(xlDown))
    Dim c As Range
    For Each c In r
        Dim s As Range: Set s = Range(シート_出力.Cells(c.Row, 列_開始), シート_出力.Cells(c.Row, 列_検索最終))
        If WorksheetFunction.CountA(s) = 1 Then
            Dim d As Range
            For Each d In s
                If d <> "" Then
                    d.Interior.ColorIndex = 強調色
                End If
            Next d
        End If
    Next c
End Sub

It can open files with password.
Improved exception handling.