ExcelでWeb検索のような検索を実現したい

「Office TANAKA」のホームページを参考にして、Excelをデータベース的に使用したいと考えています。
あるセルに検索条件を入力して、条件に合うセルを検索したいのですが、検索条件はWeb検索のように、以下の(1)～(3)ように入力したいと思っています。
(1)検索ワードをスペースで区切るとAND検索
(2)検索ワードをORで区切るとOR検索
(3)検索ワードの前に、－を付けるとNOT検索

【例】 あ　い　（う　OR　え）　－お
※上記の例は、「あ」を含み、かつ、「い」を含み、かつ、「う」または「え」を含み、かつ、「お」を含まないセルを検索する条件です。

仕事でAccessのないPCで、Excel VBAを駆使してデータベース的に使用したいと思っています。
どうか、ご協助ください。よろしくお願い致します。

No.9 回答者： mitarashi 回答日時： 2013/11/02 01:09

#8の続きです。

AND条件だけに切り分けてコレクションに収納しています。
DoEventsは何度か暴走させた名残です(^^;)

Function convertAnd(matchString As String) As Collection
Dim targetString As String, orStr As String, singleChar As String
Dim i As Long, j As Long, k As Long
Dim rBracket As Long, matchStringLength As Long
Dim mySQLseeds As Collection
Dim orConditions As Variant
Dim seed As Variant
Dim seed2() As Variant
Dim orFlag As Boolean

Set mySQLseeds = New Collection
targetString = treat(matchString)
i = 1
matchStringLength = Len(targetString)
Do Until i > matchStringLength
DoEvents: DoEvents: DoEvents
singleChar = Mid(targetString, i, 1)
Select Case singleChar
Case " "
orFlag = False
If i + 3 < matchStringLength Then
If Mid(targetString, i, 4) = " OR " Then orFlag = True
End If
If orFlag Then
If IsArray(seed) Then
For j = 0 To UBound(seed)
mySQLseeds.Add seed(j)
Next j
Else
mySQLseeds.Add seed
End If
i = i + 4
seed = Empty
Else
If IsArray(seed) Then
For j = 0 To UBound(seed)
seed(j) = seed(j) & singleChar
Next j
Else
seed = seed & singleChar
End If
i = i + 1
End If
Case "("
rBracket = InStr(i + 1, targetString, ")")
orStr = Mid(targetString, i + 1, rBracket - i - 1)
orConditions = Split(orStr, " OR ")
If UBound(orConditions) > 0 Then
' OR があるとき
If IsArray(seed) Then
ReDim seed2(0 To (UBound(seed) + 1) * (UBound(orConditions) + 1) - 1)
For k = 0 To UBound(seed)
For j = 0 To UBound(orConditions)
seed2(k * (UBound(orConditions) + 1) + j) = seed(k) & orConditions(j)
Next j
Next k
Else
ReDim seed2(0 To UBound(orConditions))
For j = 0 To UBound(orConditions)
seed2(j) = seed & orConditions(j)
Next j
End If
'seedを、seedに異なる抽出条件を付与した配列に置き換える
seed = Empty
seed = seed2
Else
If IsArray(seed) Then
For k = 0 To UBound(seed)
seed(k) = seed(k) & orConditions(0)
Next k
Else
seed = seed & orConditions(0)
End If
End If
i = rBracket + 1
Case Else
If IsArray(seed) Then
For j = 0 To UBound(seed)
seed(j) = seed(j) & singleChar
Next j
Else
seed = seed & singleChar
End If
i = i + 1
End Select
Loop
If IsArray(seed) Then
For j = 0 To UBound(seed)
mySQLseeds.Add seed(j)
Next j
Else
mySQLseeds.Add seed
End If

Set convertAnd = mySQLseeds
End Function

No.8 回答者： mitarashi 回答日時： 2013/11/02 00:59

#7です。

ますます調子に乗っていますが、そろそろ収束させていただきます。
まじめに構文を解析する方法を、#7に記したAND条件のみの複数のクエリに分ける方法で実現してみました。
UserFormにテキストボックスを一個だけ置いて実行します。（クリア用のコマンドボタンは作るべきでしょう）
Variant型の融通無碍さに吃驚コードです。全てフォームモジュールに書いています。
再掲しますが、ADOに参照設定が必要です。Sheet(1)→Sheet(3)に抽出。フィールド名は当方の事情に合わせています。
Excel or Access　にも、
Excel Access (ADO or DAO) (mdb or accdb)　にも対応しているつもりです。

4000文字に収まりきらなくなったので、二つに分けさせていただきます。

Dim cn As ADODB.Connection

Private Sub UserForm_Initialize()
Dim workFileFullPath As String

Set cn = New ADODB.Connection
workFileFullPath = getMyDocumentsPath & "\" & "work.xls"
ThisWorkbook.SaveCopyAs workFileFullPath
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.Properties("Data Source") = workFileFullPath
.Properties("Extended Properties") = "Excel 8.0;HDR=Yes;IMEX=1"
.Open
End With
End Sub

Private Sub UserForm_Terminate()
On Error Resume Next
cn.Close
Set cn = Nothing
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case vbKeyReturn
If Me.TextBox1.Value <> "" Then Call execEctract
End Select
End Sub

Sub execEctract()
Dim myCollection As Collection
Dim i As Long, j As Long
Dim buf As Variant
Dim rs As ADODB.Recordset
Dim mySQL As String
Dim myTableName As String, myFieldname As String
Dim lastCell As Range

Set rs = New ADODB.Recordset
myTableName = "[" & ThisWorkbook.Sheets(1).Name & "$]"
myFieldname = "TitleNotes"
ThisWorkbook.Sheets(3).Cells.ClearContents

Set myCollection = New Collection
Set myCollection = convertAnd(Me.TextBox1.Value)
For i = 1 To myCollection.Count
buf = Split(myCollection.Item(i), " ")
For j = 0 To UBound(buf)
If Left(buf(j), 1) = "-" Then
buf(j) = "(myFieldName not like '%" & Mid(buf(j), 2, Len(buf(j)) - 1) & "%')"
Else
buf(j) = "(myFieldName like '%" & buf(j) & "%')"
End If
Next j
mySQL = "select * from myTableName where " & Join(buf, " and ")
mySQL = Replace(mySQL, "myTableName", myTableName)
mySQL = Replace(mySQL, "myFieldName", myFieldname)

rs.Open mySQL, cn, adOpenForwardOnly, adLockOptimistic
If Not rs.BOF Then
With ThisWorkbook.Sheets(3)
Set lastCell = .Range("A" & .Rows.Count).End(xlUp)
If lastCell.Row < 2 Then
.Range("A2").CopyFromRecordset rs
Else
lastCell.Offset(1, 0).CopyFromRecordset rs
End If
End With
End If
rs.Close
Next i
ThisWorkbook.Sheets(3).Range("B2").Activate
Set rs = Nothing
End Sub

Function getMyDocumentsPath() As String
Dim objWshShell As Object

Set objWshShell = CreateObject("Wscript.Shell")
getMyDocumentsPath = objWshShell.SpecialFolders("MyDocuments")
Set objWshShell = Nothing
End Function

Function treat(sourceWord) As String
Dim buf As String
Dim lBracket As Long
Dim i As Long

buf = UCase(sourceWord)
buf = Replace(buf, "（", "(")
buf = Replace(buf, "）", ")")
buf = Replace(buf, "(", " (")
buf = Replace(buf, ")", ") ")
buf = Replace(buf, " ", " ")
buf = Replace(buf, " ＯＲ ", " OR ")
For i = 1 To 5
buf = Replace(buf, "　", " ")
Next i
buf = Replace(buf, " －", " -")
buf = Replace(buf, " ー", " -")
If Left(buf, 1) = "－" Or Left(buf, 1) = "ー" Then buf = "-" & Mid(buf, 2, Len(buf) - 1)
treat = Trim(buf)
End Function

No.7 回答者： mitarashi 回答日時： 2013/10/30 22:51

#6です。

調子に乗っています。すみません。
正規表現版を作成してみました。
(アクセス Or Access）には対応しました。
アクセス Or Access　に対応していないのは仕様です（複数のOrも考えると、スッキリした対策が浮かばないので．．．）
UserFormから呼ぶところは省略しております。
小難しいSQLを作成しないで、どうせコードで処理するので、AND条件だけのSQLを複数生成して、順次抽出する様にすれば、別の解があるのかなと感じております。

Function makeSQL(myTableName As String, myFieldname As String, matchWord As String) As String

Dim orStr As String, andStr As String
Dim andConditions As Variant, orConditions As Variant
Dim mySQL As String, whereStr As String
Dim i As Long
Dim orFlag As Boolean
Dim regEx As Variant, Matches As Variant
Dim submatchword As String, targetString As String

targetString = treat(matchWord)

Set regEx = CreateObject("VBScript.RegExp")
regEx.MultiLine = False
regEx.Pattern = "\((.+?)\)"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(targetString)
'(.+)が2個以上ヒットしていればエラーを戻す
If Matches.Count >= 2 Then
MsgBox "Or条件は一個のみ対応です"
makeSQL = "Error"
Exit Function
End If
If Matches.Count > 0 Then
orFlag = True
orStr = Matches(0).submatches.Item(0)
andStr = Trim(regEx.Replace(targetString, ""))
regEx.Pattern = "\s{2,}"
Set Matches = regEx.Execute(andStr)
If Matches.Count > 0 Then andStr = regEx.Replace(andStr, " ")
Else
andStr = targetString
End If
Set Matches = Nothing
Set regEx = Nothing

If andStr <> "" Then
andConditions = Split(andStr, " ")
For i = 0 To UBound(andConditions)
If Left(andConditions(i), 1) = "-" Then
andConditions(i) = "(myFieldName Not Like (""%" & Mid(andConditions(i), 2, Len(andConditions(i)) - 1) & "%""))"
Else
andConditions(i) = "(myFieldName Like (""%" & andConditions(i) & "%""))"
End If
Next i
whereStr = Join(andConditions, " And ")
End If

If orFlag Then
orConditions = Split(orStr, " OR ")
If andStr = "" Then
For i = 0 To UBound(orConditions)
orConditions(i) = "(" & "(myFieldName Like (""%" & orConditions(i) & "%"")))"
Next i
Else
For i = 0 To UBound(orConditions)
orConditions(i) = "(" & whereStr & " And " & "(myFieldName Like (""%" & orConditions(i) & "%"")))"
Next i
End If
End If

If orFlag Then
mySQL = "Select * From myTableName Where " & Join(orConditions, " Or ") & ";"
Else
mySQL = "Select * From myTableName Where " & whereStr & ";"
End If
mySQL = Replace(mySQL, "myTableName", myTableName)
mySQL = Replace(mySQL, "myFieldName", myFieldname)
makeSQL = mySQL
End Function

Function treat(sourceWord) As String
Dim buf As String

buf = UCase(sourceWord)
buf = Replace(buf, "（", "(")
buf = Replace(buf, "）", ")")
buf = Replace(buf, "ＯＲ", "OR")
buf = Replace(buf, "　", " ")
buf = Replace(buf, " －", " -")
buf = Replace(buf, " ー", " -")
treat = buf
End Function

この回答へのお礼

ありがとうございます。ここまで丁寧に回答して頂きまして、感謝、感激で、涙ボロボロです。

お礼日時：2013/10/31 23:27

No.6 回答者： mitarashi 回答日時： 2013/10/29 23:10

#5のバグ報告です。

括弧で囲わないで、単に「エクセル or Excel」とすると、エクセル and Or（という文字列） and Excelと見なされます。
括弧で囲って、「(エクセル or Excel）」とすると、エラーになります。小手先の対策で、And条件が一つもないとき対応に、自分用には改版しましたが、すっきりしたコードになっていません。
正規表現を使う方がすっきりするかなとも思いますが．．．

No.5 回答者： mitarashi 回答日時： 2013/10/28 22:17

#4です。

折角作ったので、本サイトでの回答履歴を収納しているエクセルのファイルに検索機能をつけてみました。アクセスのデータベースは使っていません。UserFormにTextBox一個と、コマンドボタン一個を置きます。TextBoxに「エクセル (ADO or DAO) -アクセス]といった文字列を入力して、コマンドボタンを押すと、シート3に抽出されます。元データはシート1です。フィールド名等当方のブック用です。Or条件指定の()は一組のみ対応です。
ファイルがxlsのままでしたので、Jetプロバイダを用いたためメモリリーク対策でワークファイルにコピーしてから抽出しています。実際に少し使用してみて若干のバグ修正と、長すぎて文字数をオーバーしない様に変数名を短縮しています。
'☆UserForm Module
Dim cn As ADODB.Connection

Private Sub UserForm_Initialize()
Dim workFileFullPath As String

Set cn = New ADODB.Connection

workFileFullPath = getMyDocumentsPath & "\" & "work.xls"
ThisWorkbook.SaveCopyAs workFileFullPath
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.Properties("Data Source") = workFileFullPath
.Properties("Extended Properties") = "Excel 8.0;HDR=Yes;IMEX=1"
.Open
End With
End Sub

Private Sub UserForm_Terminate()
On Error Resume Next
cn.Close
Set cn = Nothing
End Sub

Private Sub CommandButton1_Click()
Dim rs As ADODB.Recordset
Dim mySQL As String
Dim myTableName As String, myFieldname As String

Set rs = New ADODB.Recordset
myTableName = "[" & ThisWorkbook.Sheets(1).Name & "$]"
myFieldname = "TitleNotes"
mySQL = makeSQL(myTableName, myFieldname, Me.TextBox1.Value)
rs.Open mySQL, cn, adOpenForwardOnly, adLockOptimistic
If rs.BOF Then
MsgBox "該当するレコードがみつかりません"
Else
With ThisWorkbook.Sheets(3)
.Cells.Clear
.Range("A2").CopyFromRecordset rs
End With
End If
rs.Close
Set rs = Nothing
End Sub

'☆標準モジュール
Sub execExtract()
UserForm1.Show vbModeless
End Sub

Function makeSQL(myTableName As String, myFieldname As String, matchWord As String) As String
Dim lpos As Long, rpos As Long
Dim orStr As String, andStr As String
Dim andConditions As Variant, orConditions As Variant
Dim mySQL As String, whereStr As String
Dim i As Long
Dim orFlag As Boolean

matchWord = treat(matchWord)
lpos = InStr(matchWord, "(")
If lpos > 0 Then
rpos = InStr(lpos + 1, matchWord, ")")
orStr = Mid(matchWord, lpos + 1, rpos - lpos - 1)
If rpos = Len(matchWord) Then
andStr = Left(matchWord, lpos - 2)
Else
andStr = Left(matchWord, lpos - 1) & Right(matchWord, Len(matchWord) - rpos - 1)
End If
andConditions = Split(andStr, " ")
orConditions = Split(orStr, " OR ")
orFlag = True
Else
andConditions = Split(matchWord, " ")
End If
For i = 0 To UBound(andConditions)
If Left(andConditions(i), 1) = "-" Or Left(andConditions(i), 1) = "－" Then
andConditions(i) = "(myFieldName Not Like (""%" & Mid(andConditions(i), 2, Len(andConditions(i)) - 1) & "%""))"
Else
andConditions(i) = "(myFieldName Like (""%" & andConditions(i) & "%""))"
End If
Next i
whereStr = Join(andConditions, " And ")
If orFlag Then
For i = 0 To UBound(orConditions)
If Left(orConditions(i), 1) = "-" Or Left(orConditions(i), 1) = "－" Then
orConditions(i) = "(" & whereStr & " And " & "(myFieldName Not Like (""%" & Mid(orConditions(i), 2, Len(orConditions(i)) - 1) & "%"")))"
Else
orConditions(i) = "(" & whereStr & " And " & "(myFieldName Like (""%" & orConditions(i) & "%"")))"
End If
Next i
mySQL = "Select * From myTableName Where " & Join(orConditions, " Or ") & ";"
Else
mySQL = "Select * From myTableName Where " & whereStr & ";"
End If
mySQL = Replace(mySQL, "myTableName", myTableName)
mySQL = Replace(mySQL, "myFieldName", myFieldname)
makeSQL = mySQL
End Function

Function treat(sourceWord) As String
Dim buf As String

buf = UCase(sourceWord)
buf = Replace(buf, "（", "(")
buf = Replace(buf, "）", ")")
buf = Replace(buf, "ＯＲ", "OR")
buf = Replace(buf, "　", " ")
treat = buf
End Function

Function getMyDocumentsPath() As String
Dim objWshShell As Object

Set objWshShell = CreateObject("Wscript.Shell")
getMyDocumentsPath = objWshShell.SpecialFolders("MyDocuments")
Set objWshShell = Nothing
End Function

No.4 回答者： mitarashi 回答日時： 2013/10/28 00:05

徒然なるままに作成してみました。

ADO（またはDAO)を用いて、SQLを生成して抽出するのが比較的容易と判断しました。
AccessのないPCでもAccessのデータベースを、Excelから使用できます。データベースを作成するExcelVBAコードは検索すれば転がっていると思いますが、Accessの入っているPCで作成して持ってくるのが楽です。抽出する前に、書き込まなければなりませんが、参考URL等をご覧下さい。また、Excelのワークシートからも同様に抽出可能ですが、SQLが煩雑になります。
こんな風にすれば出来るかもというレベルのサンプルコードです。（吟味不足で申し訳ないですが、時間切れです。）ご質問者様の環境に合わせてアレンジするのは承りかねます。ご興味をもたれたら、ご自分でお願いします。

'Microsoft ActiveX Data Objects ?.? Libraryに参照設定
'http://www.excel-excel.com/tips/tipsdatabase.html
Sub extractAccdb()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim mySQL As String
Const myDbName As String = "Database16.accdb"

Set cn = New ADODB.Connection
cn.Provider = "Microsoft.Ace.OLEDB.12.0"
'Database16.accdbというデータベースのTable1にField1というフィールド一個だけの試験データ作成
cn.Open getMyDocumentsPath & "\" & myDbName
Set rs = New ADODB.Recordset
mySQL = makeSQL("Table1", "Field1", "あ　い　（う　OR　え）　－お")
'Select * From Table1 Where ((Field1 Like ("%あ%")) And (Field1 Like ("%い%")) And (Field1 Not Like ("%お%")) And (Field1 Like ("%う%"))) Or ((Field1 Like ("%あ%")) And (Field1 Like ("%い%")) And (Field1 Not Like ("%お%")) And (Field1 Like ("%え%")));

rs.Open mySQL, cn, adOpenForwardOnly, adLockOptimistic
If rs.BOF Then
MsgBox "該当するレコードが見つかりません。"
Else
'抽出結果をワークシートに貼り付けます
ThisWorkbook.Sheets(1).Range("A1").CopyFromRecordset rs
End If
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
End Sub

'ADOの場合ワイルドカードは%にする必要がある事に留意
Function makeSQL(myTableName As String, myFieldName As String, matchWord As String) As String
Dim leftParentheses As Long, rightParentheses As Long
Dim orStr As String, andStr As String
Dim andConditions As Variant, orConditions As Variant
Dim mySQL As String
Dim i As Long

matchWord = treat(matchWord)
leftParentheses = InStr(matchWord, "(")
'このあたり、エラー処理が必要ですが出来ていません
If leftParentheses > 0 Then
rightParentheses = InStr(leftParentheses + 1, matchWord, ")")
orStr = Mid(matchWord, leftParentheses + 1, rightParentheses - leftParentheses - 1)
andStr = Left(matchWord, leftParentheses - 1) & Right(matchWord, Len(matchWord) - rightParentheses - 1)
andConditions = Split(andStr, " ")
orConditions = Split(orStr, " OR ")
End If
For i = 0 To UBound(andConditions)
If Left(andConditions(i), 1) = "-" Or Left(andConditions(i), 1) = "－" Then
andConditions(i) = "(myFieldName Not Like (""%" & Mid(andConditions(i), 2, Len(andConditions(i)) - 1) & "%""))"
Else
andConditions(i) = "(myFieldName Like (""%" & andConditions(i) & "%""))"
End If
Next i
mySQL = Join(andConditions, " And ")
For i = 0 To UBound(orConditions)
If Left(orConditions(i), 1) = "-" Or Left(orConditions(i), 1) = "－" Then
orConditions(i) = "(" & mySQL & " And " & "(myFieldName Not Like (""%" & Mid(orConditions(i), 2, Len(orConditions(i)) - 1) & "%"")))"
Else
orConditions(i) = "(" & mySQL & " And " & "(myFieldName Like (""%" & orConditions(i) & "%"")))"
End If
Next i
mySQL = "Select * From myTableName Where " & Join(orConditions, " Or ") & ";"
mySQL = Replace(mySQL, "myTableName", myTableName)
mySQL = Replace(mySQL, "myFieldName", myFieldName)
' mySQL = Replace(mySQL, Chr(34), Chr(39))
makeSQL = mySQL
End Function

'揺らぎ対策の一例
Function treat(sourceWord) As String
Dim buf As String

buf = UCase(sourceWord)
buf = Replace(buf, "（", "(")
buf = Replace(buf, "）", ")")
buf = Replace(buf, "ＡＮＤ", "AND")
buf = Replace(buf, "ＯＲ", "OR")
buf = Replace(buf, "　", " ")
' buf = Replace(buf, "－", "-") ' '文中に－があると厄介
treat = buf
End Function

Private Function getMyDocumentsPath() As String
Dim objWshShell As Object

Set objWshShell = CreateObject("Wscript.Shell")
getMyDocumentsPath = objWshShell.SpecialFolders("MyDocuments")
Set objWshShell = Nothing
End Function

No.3 回答者： h_tana_0530 回答日時： 2013/10/27 19:50

こんばんは。

外部アドインを使わずに、データベース関数も使わずに、VBAだけでベタでプログラムを作るのは、かなり骨がおれそうですね。やるとすれば（の話ですが）
１．　検索キーワードを抽出する。（スペース、カッコ、"OR"、などのセパレータで分解する。）
２．　それぞれのキーワードについて検索結果を判定する。　あり＝１、無し＝０　とする。
　　　NOT検索したい項目はあり＝０、無し＝１　とする。
３．　検索結果を検索条件で計算式に組み立てる。（文字列にする。）
　　　例題で書けば　("あ"の検索結果）*("い"の検索結果）*(("う"の検索結果）+("え"の検索結果）)*("お"の検索結果のNOT）
４．　組み立てた計算式を、Evaluate関数で計算する。
５．　結果が＞０ならば検索ヒット、０ならばヒットせず、と判断する。
１～５を各レコード毎に実施して判定する。

１万件超えるようなデータベースだと、判定計算にかなり時間が掛かると思うので、あまりお勧めはしませんです。

この回答へのお礼

ありがとうございます。参加になりました。

お礼日時：2013/10/31 23:20

No.2 回答者： kmetu 回答日時： 2013/10/27 10:46

No1です

フィルターを利用するという手もあります


なんだ！カンタン！Excel塾
複雑な条件を指定して一度にデータを抽出する
http://kokodane.com/tec2_8.htm

No.1 回答者： kmetu 回答日時： 2013/10/27 10:42

Excel用正規表現検索ダイアログアドイン

http://srcedit.pekori.jp/tool/excelre.html

上記のアドインを利用すると検索条件の記載方法は違います(正規表現の記載方法になります)が様々な検索ができます。

この回答へのお礼

ありがとうございます。参考になりました。コードが見れたら最高ですね。

お礼日時：2013/10/31 23:15