- ホーム
- Other
- weblikesearch
WebのようなAnd/Orを複合した検索を実現する
QAサイトでExcelでWebの様なAnd/Orを複合した検索を実現するという課題がありました
Excel Access
Excel or Access
Excel Access (ADO or DAO) -mdb
といった検索指定です。
最初複雑なSQLを生成して、ADOを使って抽出すれば比較的容易に実現できるのではと思い、Split関数または、正規表現でAnd/Orの要素を配列に取り込んで処理する方法でやってみました。
色々やっているうちに、SQL一発で処理する必要は無く、AND条件のみのSQLを複数生成して順次抽出すれば、正統的に構文を頭から解釈する方法が実現できるのではと思い至りました。
配列の中味を次第に要素数が増えていく（中味は追記では無くて、複数要素の組み合わせによる入れ替え）配列で置き換える方法に苦労しましたが、新たに作成したVariant型の配列を、元のVariant変数または配列に代入してすげ替えれば良い事がわかりました。
Variant型は融通無碍ですね。
Excel版（ワークシートから抽出）と、Access版があります。Excel版は単独フィールドしか検索できませんが、HDR=Noにして、フィールド名F1～Fnまで順次検索してやればシート全体検索も可能だと思います。
バグ修正：検索文の揺らぎ対策のコードで一部意図したものと入れ替わってしまっている箇所があり、対策が不十分になっていたので修正しました。
'================= Excel版 ワークシートから抽出 =================
'☆標準モジュール
Sub execExtract()
UserForm1.Show vbModeless
End Sub
'☆UserFormモジュール
Dim cn As ADODB.Connection
Private Sub UserForm_Initialize()
Dim workFileFullPath As String
'Jetプロバイダには自ワークブックに接続するとメモリリークが発生するバグがあるので
'コピーを作成してそちらから抽出している
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 '13
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 dataRange As Range, myCell As Range, lastCell As Range
Set rs = New ADODB.Recordset
myTableName = "[" & ThisWorkbook.Sheets(1).Name & "$]"
myFieldname = "FieldName"
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)
Debug.Print mySQL
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
Set dataRange = .Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3)
End With
For Each myCell In dataRange.Columns(1).Cells
myCell.Hyperlinks.Add Anchor:=myCell, Address:=myCell.Value, TextToDisplay:=myCell.Value
Next myCell
End If
rs.Close
Next i
ThisWorkbook.Sheets(3).Range("B2").Activate
Set rs = Nothing
End Sub
'and条件（半角スペースをデリミタとする）のみの文字列のコレクションに変換する
'orは複数クエリの実行、追記により実現する
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)
Debug.Print "targetstring:", targetString
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 があるとき
'seedが配列の時
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に異なるOr条件を付与した配列に置き換える
seed = Empty '無くても良いが分かりやすく
seed = seed2
Else
' OR がないとき
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
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, ")", ") ")
'バグ修正 aのところは全角スペース→半角スペース、bのところは半角スペース2個→半角スペース1個変換が正解ですが、入れ替わっていました
buf = Replace(buf, " ", " ") 'a
buf = Replace(buf, " ＯＲ ", " OR ")
For i = 1 To 5
buf = Replace(buf, " ", " ") 'b
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
Function getMyDocumentsPath() As String
Dim objWshShell As Object
Set objWshShell = CreateObject("Wscript.Shell")
getMyDocumentsPath = objWshShell.SpecialFolders("MyDocuments")
Set objWshShell = Nothing
End Function
'================= Access版 ワークテーブルに書き出してフォームのRecordSourceに設定 =================
Option Compare Database
Option Explicit
'帳票フォーム（旧称）のヘッダーセクションに、対象フィールド選択のコンボボックスと、テキストボックス、クリア用のボタンを設定
Private Sub clearButton_Click()
Me.extractText.Value = ""
End Sub
Private Sub extractText_AfterUpdate()
If IsNull(Me.extractText.Value) Or IsNull(Me.fieldCombo.Value) Then
Exit Sub
Else
Call execEctract
End If
End Sub
'なぜか新しいテキストを入力しても再度Enterを押さないと無効なときがあるのでAfterUpdate使用に変更
'Private Sub extractText_KeyDown(KeyCode As Integer, Shift As Integer)
'End Sub
'DoCmd.Runsqlはワイルドカード%は無効だった（何かが抽出されたが謎）
Sub execEctract()
Dim myCollection As Collection
Dim i As Long, j As Long
Dim buf As Variant
Dim mySQL As String
Dim myTableName As String, myFieldname As String
Dim dataRange As Range, myCell As Range, lastCell As Range
myTableName = "Table1"
'Comboから選択
If Me.fieldCombo.Value <> "" Then myFieldname = Me.fieldCombo.Value
'ワーク用のテーブルをクリア
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from t_work"
DoCmd.SetWarnings True
Set myCollection = New Collection
Set myCollection = convertAnd(Me.extractText.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 = "INSERT INTO t_work SELECT * FROM myTableName WHERE " & Join(buf, " and ")
mySQL = Replace(mySQL, "myTableName", myTableName)
mySQL = Replace(mySQL, "myFieldName", myFieldname)
DoCmd.SetWarnings False
DoCmd.RunSQL mySQL
DoCmd.SetWarnings True
Next i
'Q_extractはt_workのコード番号をマスタと関連づけたクエリ
Me.RecordSource = "Q_extract"
End Sub
'and条件（半角スペースをデリミタとする）のみの文字列のコレクションに変換する
'orは複数クエリの実行、追記により実現する
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)
' Debug.Print "targetstring:", targetString
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 があるとき
'seedが配列の時
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に異なるOr条件を付与した配列に置き換える
seed = Empty '無くても良いが分かりやすく
seed = seed2
Else
' OR がないとき
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
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, ")", ") ")
'バグ修正 aのところは全角スペース→半角スペース、bのところは半角スペース2個→半角スペース1個変換が正解ですが、入れ替わっていました
buf = Replace(buf, " ", " ") 'a
buf = Replace(buf, " ＯＲ ", " OR ")
For i = 1 To 5
buf = Replace(buf, " ", " ") 'b
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
Function getMyDocumentsPath() As String
Dim objWshShell As Object
Set objWshShell = CreateObject("Wscript.Shell")
getMyDocumentsPath = objWshShell.SpecialFolders("MyDocuments")
Set objWshShell = Nothing
End Function