Sub GetRowsWithKeywordInSecondColumn()
    Dim conn As Object
    Dim rs As Object
    Dim filePath As String
    Dim sql As String
    Dim keyword As String

    filePath = "C:\Test\Book1.xlsx" ' ← 適宜変更
    keyword = "りんご"              ' ← 検索したい文字

    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & filePath & ";" & _
              "Extended Properties='Excel 12.0 Xml;HDR=Yes;IMEX=1'"

    ' ★2列目の列名を指定（例：「商品名」列）
    sql = "SELECT * FROM [Sheet1$] WHERE 商品名 LIKE '%" & keyword & "%'"

    rs.Open sql, conn, 1, 1

    If Not rs.EOF Then
        Do Until rs.EOF
            Debug.Print rs.Fields(0).Value, rs.Fields(1).Value ' ←必要な列を表示
            rs.MoveNext
        Loop
    Else
        MsgBox "該当データが見つかりません"
    End If

    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub