Excel や Access のフォームの中でいわゆるインターネットの検索窓のようなものを構築できま

Question

Excel や Access のフォームの中でいわゆるインターネットの検索窓のようなものを構築できますか

検索窓に任意の単語をスペースを空けて複数入れれば該当するものがデータベースで現れるという仕組みです

どのようにできるでしょうかインターネットで検索したのですが良いものが見当たりません

KenKen_SP · Accepted Answer

モードレス表示なので、例えば
　Sheet1をアクティブにして東京のデータ抽出
　Sheet2をアクティブにして大阪のデータ抽出
みたいな使い方ができます。

複数キーワードはスペースで区切ると添付の画像のように。

いろいろ手抜きです。

手元にあったビックデータが郵便番号CSV(12万レコード）しかなかったので、その範囲で手抜きエラートラップしてます。
オーバーフローとかあるかもしれないです。

ソースの[設定]と書かれた部分をご自身の環境に書き換えて下さい。

KenKen_SP · Answer

' 続き

' SQLを生成
'
Private Function CreateSQL() As String

Dim fname As String:　　　 fname = ComboBox1.Text
　　Dim ftype As DataTypeEnum: ftype = ComboBox1.List(ComboBox1.ListIndex, 1)
　　Dim param As Variant:　　　param = TextBox1.Text
　　　　　
　　param = Replace$(param, Chr$(&H8140), Chr$(&H20)) ' 全角SPを半角SPに置換
　　param = WorksheetFunction.Trim$(param)　　　　　　' 不要SPドロップ
　　　　　
　　If Len(param) = 0 Then Exit Function　　　　　　　' 入力値がなければ終了
　　'
　　Select Case ftype
　　　　'データ型によってWHERE句を生成する
　　　　Case adUnsignedTinyInt, adSmallInt, adInteger, adSingle, adDouble, adCurrency
　　　　　　' 数値型
　　　　　　param = CheckValue(param, "num")
　　　　　　param = " WHERE [" & fname & "] = " & Join$(param, " %OP% [" & fname & "] = ")
　　　　Case adDate, adDBTimeStamp
　　　　　　' 日付型
　　　　　　param = CheckValue(param, "date")
　　　　　　param = " WHERE [" & fname & "] = #" & Join$(param, "# %OP% [" & fname & "] = #") & "#"
　　　　Case adVarWChar, adLongVarWChar
　　　　　　' 文字列
　　　　　　param = CheckValue(param, "string")
　　　　　　param = " WHERE [" & fname & "] LIKE '%" & Join$(param, "%' %OP% [" & fname & "] LIKE '%") & "%'"
　　End Select
　
　　Dim sql As String
　　sql = sql & "SELECT *"
　　sql = sql & " FROM [" & DB_TABLENAME & "]"
　　sql = sql & param
　　sql = Replace$(sql, "%OP%", Me.ComboBox2.Text)

CreateSQL = sql

End Function

' 検索キーのチェック関数
'
Private Function CheckValue( _
　　ByVal data As Variant, _
　　ByVal dtype As String _
) As Variant

Dim escape As Variant: escape = Array("<", ">", ".", "*", ":", "^", "+", "\", "=", "&", "/")
　　Dim i　　　As Long, j　As Long
　　
　　data = Split(data, Chr$(&H20))

For i = 0 To UBound(data)
　　　　Select Case dtype
　　　　　　Case "num"
　　　　　　　　data(i) = StrConv(data(i), vbNarrow)
　　　　　　　　If Not IsNumeric(data(i)) Then
　　　　　　　　　　data(i) = Chr$(&H20)
　　　　　　　　End If
　　　　　　Case "date"
　　　　　　　　data(i) = StrConv(data(i), vbNarrow)
　　　　　　　　If Not IsDate(data(i)) Then
　　　　　　　　　　data(i) = Chr$(&H20)
　　　　　　　　End If
　　　　　　Case "string"
　　　　　　　　' SQL禁則文字のエスケープ
　　　　　　　　For j = 0 To UBound(escape)
　　　　　　　　　　data(i) = Replace$(data(i), escape(j), "[" & escape(j) & "]")
　　　　　　　　Next
　　　　End Select
　　Next
　　
　　data = Join$(data, Chr$(&H20))
　　data = WorksheetFunction.Trim$(data)
　　data = Split(data, Chr$(&H20))

CheckValue = data

End Function

KenKen_SP · Answer

' 以下全てのソースコードをUserform1にコピペする

Option Explicit

' *******************************************************************
' ADO を利用したACCESSデータベースの検索フォーム
' 要参照設定： Microsoft ActiveX DataObjects x.x Library
' *******************************************************************

'// [設定 環境に合わせて変更する]------------------------------------
'
' Access ファイル名（パス付き）
Private Const DB_FILENAME　As String = "W:\202205\voiceofcustomer\202101-202205.accdb"
' Access テーブル名
Private Const DB_TABLENAME As String = "元TB"
'
'-------------------------------------------------------------------

Private m_cn　　　　 As ADODB.Connection
Private m_rs　　　　 As ADODB.Recordset
Private m_columns()　As Variant

Private Sub UserForm_Initialize()
　　Call InitFormDesgin
　　If OpenDB(DB_FILENAME) Then
　　　　Call GetColumnsInfo
　　　　With ComboBox1
　　　　　　.List = m_columns
　　　　　　.ListIndex = 0
　　　　End With
　　End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
　　Call CloseDB
End Sub

Private Sub CommandButton1_Click()
　
　　Dim sql As String: sql = CreateSQL()
　　
　　If Len(sql) = 0 Then Exit Sub
　　　　
　　Set m_rs = New ADODB.Recordset
　
　　On Error GoTo Err_
　　m_rs.Open sql, m_cn, adOpenKeyset, adLockOptimistic
　　On Error GoTo 0

If ActiveWorkbook Is ThisWorkbook Then
　　　　With ActiveSheet '↓ ActveSheetの内容を書き換えるので注意
　　　　　　.Cells.Delete
　　　　　　.DrawingObjects.Delete
　　　　　　.Range("A1").Resize(, UBound(m_columns) + 1).Value = Application.WorksheetFunction.Transpose(m_columns)
　　　　　　.Range("A2").CopyFromRecordset m_rs
　　　　　　.Cells(1).Activate
　　　　　　.Cells(1).AutoFilter
　　　　End With
　　End If
　　
Bye_:
　　Set m_rs = Nothing
　　Exit Sub
Err_:
　　MsgBox "検索できませんでした", vbCritical
　　TextBox1.SetFocus
　　SendKeys "^A"
　　Resume Bye_
End Sub

' フォームデザインの初期化
'
Private Sub InitFormDesgin()
　　With Me
　　　　.Width = 390: .Height = 47
　　　　.Caption = "検索キーワードはスペース区切り"
　　End With
　　With Me.TextBox1
　　　　.Left = 0:　　.Top = 0
　　　　.Width = 192: .Height = 18
　　　　.BorderStyle = fmBorderStyleSingle
　　　　.TabKeyBehavior = True
　　　　
　　End With
　　With Me.ComboBox1
　　　　.Left = 192: .Top = 0
　　　　.Width = 96: .Height = 18
　　　　.BorderStyle = fmBorderStyleSingle
　　　　.BoundColumn = 2
　　　　.ColumnWidths = "96;0"
　　　　.TabStop = False
　　　　.Style = fmStyleDropDownList
　　End With
　　With Me.ComboBox2
　　　　.Left = 288: .Top = 0
　　　　.Width = 48: .Height = 18
　　　　.BorderStyle = fmBorderStyleSingle
　　　　.TabStop = False
　　　　.Style = fmStyleDropDownList
　　　　.TextAlign = fmTextAlignCenter
　　　　.AddItem "OR"
　　　　.AddItem "AND"
　　　　.ListIndex = 0
　　End With
　　With Me.CommandButton1
　　　　.Left = 336: .Top = 0
　　　　.Width = 42: .Height = 18
　　　　.Caption = "検索"
　　　　.TakeFocusOnClick = False
　　End With
End Sub

' ACCESS データベースを開く
'
Private Function OpenDB( _
　　　　ByRef source_filename As String _
) As Boolean
　　
　　On Error GoTo Err_
　　
　　Set m_cn = New ADODB.Connection
　　m_cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" _
　　　　　　　　　　　　　　　& "Data Source=" & source_filename & ";"
　　OpenDB = True
　　
Bye_:
　　Exit Function
Err_:
　　Set m_cn = Nothing
　　MsgBox "データベースに接続できません", vbCritical
　　Resume Bye_

End Function

' ACCESS データベースを閉じる
'
Private Sub CloseDB()
　　On Error Resume Next
　　m_rs.Close: Set m_rs = Nothing
　　m_cn.Close: Set m_cn = Nothing
End Sub

' テーブルのカラム情報をモジュールレベル変数に取得
'
Private Sub GetColumnsInfo()
　　
　　If m_cn Is Nothing Then Exit Sub
　　
　　Set m_rs = New ADODB.Recordset
　　m_rs.Open DB_TABLENAME, m_cn ', adOpenKeyset, adLockOptimistic

ReDim m_columns(m_rs.Fields.Count - 1, 1)
　　'
　　Dim i　As Long
　　For i = 0 To m_rs.Fields.Count - 1
　　　　m_columns(i, 0) = m_rs.Fields(i).Name ' 1列目 カラム名
　　　　m_columns(i, 1) = m_rs.Fields(i).Type ' 2列目 データ型 (幅0で非表示)
　　Next
　　'
　　m_rs.Close: Set m_rs = Nothing

End Sub

KenKen_SP · Answer

こんにちは。

以前作成したものを手直しました。簡単なテストしかしてませんし、複雑なのでご参考程度に。
適当にカスタマイズして使って下さい。

概略
AccessデータベースにADOで接続し、データ抽出を行う
検索カラムはコンボボックスで指定
AND、OR検索
複数の検索キーはスペース区切りで指定する
結果をワークシートに展開する
フォームはモードレス表示とする
※全てのエラーをトラップしてませんので、自己責任で

手順

1. Excelブックを新規作成し、[マクロ有効ブック]形式で保存
2. VBEエディターを開いて[ツール]-[参照設定]で次をチェック
　　Microsoft ActiveX Data Objects 2.8 Library
　　2.8が無ければ近いものを
3. [挿入]-[ユーザーフォーム]（名前 Userform1)
4. ３．のフォームに次の４つのコントロールを配置
　　TextBox1
　　ComboBox1
　　ComboBox2
　　CommandButton1
　　適当に配置して大丈夫ですが、名前は記載のとおり
5. [挿入]-[標準モジュール]
6. 5に次のソースをコピペ

Public Sub 検索フォーム表示()
　　UserForm1.Show False
End Sub

7. 6を実行してフォームが表示されることを確認

長いので次の回答でソース貼ります。

bonaron · Answer

こちらが参考になるかもしれません。

AccessでWEB検索のように曖昧検索したい
https://hatenachips.blog.fc2.com/blog-entry-96.html

KenKen_SP · Answer

こんにちは

データは表示はexcel側でいいですか？
恐らくその方が操作が簡単でしょう。
VBA はどちらにせよ、使うことになります。

1. Access のファイルの名前(パス付きで)
2. Access に取り込んだデータのテーブル名

を教えてください。

KenKen_SP · Answer

ごめんなさい 
勘違いしてたかもしれません。

データベースの話なら、Textboxの中身をスペースでSplitを使い配列化、配列のループでSQLのWHERE句をORまたはANDで生成、、ということではない？

具体的な出来上がりイメージを下さい。

lv4u · Answer

＞＞Excel や Access のフォームの中でいわゆるインターネットの検索窓のようなものを構築できますか

えーと、そういうのは、わりと良くある処理だと思います。
たた、そういう処理ってのは、VBAというか、プログラムで記述する処理になりますね。
確かにネットで探すと良いものはないかもしれません。

私の経験だと、ネットで探して分かるものもあるけど、筋道たてて学んでいくとなると、やっぱり書店で探して、良さそうな書籍を購入してそれを参考にするしかなかった気がします。

あるていど分かってしまうと、どんなキーワードで探せばいいか分かるし、断片情報であっても、それで解決できたりしますが、最初はやっぱり３～４千円とか、場合によっては１万円近い専門書を買って読まないと、欲しい情報が手に入らないってことありそうです・・・。

KenKen_SP · Answer

こんにちは。

できるかと問われれば、できます。

キーワード   web api  XMLHTTP60

など。

Textboxに入力されたキーワードからリクエストURLを生成してポストします。
帰ってきた結果(XMLなど)を解析して、リストボックスなどへ出力。

簡単に言えば、こんな感じです。

Excel や Access のフォームの中でいわゆるインターネットの検索窓のようなものを構築できま

モードレス表示なので、例えば

' 続き

' 以下全てのソースコードをUserform1にコピペする

こんにちは。

こちらが参考になるかもしれません。

こんにちは

ごめんなさい

＞＞Excel や Access のフォームの中でいわゆるインターネットの検索窓のようなものを構築できますか

こんにちは。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング