VBAで別ブックの全シートをADO検索して指定範囲のデータを取得する方法（非表示・読み取り専用）

業務で大量のExcelファイルを扱っていると、「他のブックの中から特定の文字列を検索して、周辺のデータも取得したい」という場面があります。

この記事では、Excel VBA + ADO を使って、他のブックの全シートを開かずに検索し、検索されたセル周辺の任意範囲のデータを取得する方法をご紹介します。

特徴

• 他のExcelファイルを開かずにデータを検索（ADO使用）
• 読み取り専用アクセスで安全
• 全シート対象
• 行／列検索の切り替えが可能
• 検索結果のセルを基準に、マイナス方向も含めた範囲指定が可能
• 結果に シート名とセルアドレス を含む

実装コード（VBA関数）

以下のコードを標準モジュールに貼り付けてください。

Function SearchExcelAllSheetsWithADO( _
    targetFilePath As String, _
    searchByRow As Boolean, _
    searchTargetIndex As Long, _
    keyword As String, _
    readRows As Long, _
    readCols As Long, _
    rowOffset As Long, _
    colOffset As Long _
) As Variant

    On Error GoTo ErrHandler

    Dim conn As Object
    Dim rs As Object
    Dim query As String
    Dim resultList As Collection
    Dim sheetList As Collection
    Dim rowData() As Variant
    Dim i As Long, j As Long, k As Long
    Dim sheetName As Variant

    Set resultList = New Collection

    ' ADO接続（読み取り専用）
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & targetFilePath & ";" & _
              "Extended Properties='Excel 12.0;HDR=YES;IMEX=1;ReadOnly=True';"

    ' シート一覧取得
    Set sheetList = New Collection
    Dim cat As Object
    Set cat = CreateObject("ADOX.Catalog")
    Set cat.ActiveConnection = conn
    Dim tbl As Object
    For Each tbl In cat.Tables
        If Right(tbl.Name, 1) = "$" Or InStr(tbl.Name, "$'") > 0 Then
            sheetList.Add tbl.Name
        End If
    Next

    ' 各シート処理
    For Each sheetName In sheetList
        query = "SELECT * FROM [" & sheetName & "]"
        Set rs = CreateObject("ADODB.Recordset")
        rs.Open query, conn, 1, 1

        If Not rs.EOF Then
            Dim data As Variant
            data = rs.GetRows
            Dim rowCount As Long: rowCount = UBound(data, 2)
            Dim colCount As Long: colCount = UBound(data, 1)

            If searchByRow Then
                For i = 0 To rowCount
                    If searchTargetIndex - 1 <= colCount Then
                        If Not IsNull(data(searchTargetIndex - 1, i)) Then
                            If InStr(CStr(data(searchTargetIndex - 1, i)), keyword) > 0 Then
                                ReDim rowData(0 To readRows * readCols + 1)
                                rowData(0) = Replace(sheetName, "$", "")
                                rowData(1) = Cells(i + 1, searchTargetIndex).Address(False, False)
                                For j = 0 To readRows - 1
                                    For k = 0 To readCols - 1
                                        Dim targetRow As Long: targetRow = i + j + rowOffset
                                        Dim targetCol As Long: targetCol = searchTargetIndex - 1 + k + colOffset
                                        If targetRow >= 0 And targetRow <= rowCount And targetCol >= 0 And targetCol <= colCount Then
                                            rowData(j * readCols + k + 2) = data(targetCol, targetRow)
                                        Else
                                            rowData(j * readCols + k + 2) = ""
                                        End If
                                    Next k
                                Next j
                                resultList.Add rowData
                            End If
                        End If
                    End If
                Next i
            Else
                If searchTargetIndex - 1 <= rowCount Then
                    For i = 0 To colCount
                        If Not IsNull(data(i, searchTargetIndex - 1)) Then
                            If InStr(CStr(data(i, searchTargetIndex - 1)), keyword) > 0 Then
                                ReDim rowData(0 To readRows * readCols + 1)
                                rowData(0) = Replace(sheetName, "$", "")
                                rowData(1) = Cells(searchTargetIndex, i + 1).Address(False, False)
                                For j = 0 To readRows - 1
                                    For k = 0 To readCols - 1
                                        Dim targetRow As Long: targetRow = searchTargetIndex - 1 + j + rowOffset
                                        Dim targetCol As Long: targetCol = i + k + colOffset
                                        If targetRow >= 0 And targetRow <= rowCount And targetCol >= 0 And targetCol <= colCount Then
                                            rowData(j * readCols + k + 2) = data(targetCol, targetRow)
                                        Else
                                            rowData(j * readCols + k + 2) = ""
                                        End If
                                    Next k
                                Next j
                                resultList.Add rowData
                            End If
                        End If
                    Next i
                End If
            End If
        End If
        rs.Close
        Set rs = Nothing
    Next

    conn.Close
    Set conn = Nothing
    Set cat = Nothing

    If resultList.Count > 0 Then
        ReDim outputArr(1 To resultList.Count)
        For k = 1 To resultList.Count
            outputArr(k) = resultList(k)
        Next k
        SearchExcelAllSheetsWithADO = outputArr
    Else
        SearchExcelAllSheetsWithADO = Empty
    End If
    Exit Function

ErrHandler:
    MsgBox "エラーが発生しました：" & vbCrLf & Err.Description, vbExclamation
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
    If Not conn Is Nothing Then If conn.State = 1 Then conn.Close
    Set rs = Nothing
    Set conn = Nothing
    Set cat = Nothing
    SearchExcelAllSheetsWithADO = Empty
End Function

使用例

Sub TestSearch()
    Dim results As Variant
    results = SearchExcelAllSheetsWithADO( _
        "C:\temp\sample.xlsx", _
        True,  ' True = 行で検索 / False = 列で検索
        2, _
        "検索キーワード", _
        3,  ' 行数
        2,  ' 列数
        -1, ' 行オフセット（-1行から開始）
        0)  ' 列オフセット（その列から）

    If Not IsEmpty(results) Then
        Dim i As Long, j As Long
        For i = LBound(results) To UBound(results)
            Debug.Print "シート: " & results(i)(0), "セル: " & results(i)(1)
            For j = 2 To UBound(results(i))
                Debug.Print results(i)(j)
            Next j
        Next i
    Else
        MsgBox "該当なし"
    End If
End Sub

パラメータの意味

注意点

• ADOを使うには Microsoft.ACE.OLEDB.12.0 がインストールされている必要があります。
• .xlsx ファイルは Excel 2007以降用の形式です。
• フィルタや数式などがある場合、値のみ取得されます。
• セルに改行がある場合、取得内容に注意してください。

最後に

大量のExcelファイルを横断的に検索し、情報を抽出したい場面で非常に有用な手法です。
本記事のコードを活用して、検索・抽出の自動化にぜひご活用ください！