検索結果の一覧リストの表示について【Excel2010 VBA】

Question

いつもお世話になっております。VBAの初心者です。仕事上、Excelで年度ごとにシートをわけた顧客の管理データのようなものを作成し、キーワードで検索、該当したデータを一覧リストに表示するようにしています。ただ、キーワードによっては、同じ行で複数一致してしまうため、同一行が複数リストに表示されてしまいます。そこで、同じ行で複数一致した場合でも、リストに表示するのは1件のみ表示という風にすることはできませんでしょうか？勉強途中で理解していないつたない書き方でお恥ずかしい限りですが、現在のコードは下記のとおりです。そのため、検索にも時間がかかってしまっておりますので、ここを直せば検索スピードがあがるということもありましたら、合わせてご教示いただけましたら幸いです。お手数をおかけいたしますが、よろしくお願いいたします。 Excel2010 検索対象シート：2016,2017,2018（そのほかリスト、検索結果表示ｼｰﾄ等あり） 1シートに3,000～5,000件 A～AHまで入力（会社名、カタカナ読み、氏名、カタカナ読み、住所、生年月日、登録日等） Private Sub 検索_Click() Me.一覧リスト.Clear Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Me.キーワード検索.Value = "" Then Exit Sub If キーワードⅡ.Value = "" And キーワードⅢ.Value <> "" Then MsgBox "ｷｰﾜｰﾄﾞ2を入力してください。", vbOKOnly + vbInformation Exit Sub End If w = Array("2016", "2017", "2018") For Each ws In Worksheets(w) Set r = ws.Cells.Find(what:=Me.キーワード検索.Value, lookat:=xlPart, MatchCase:=False, MatchByte:=False, LookIn:=xlValues) If Not r Is Nothing Then fAddr = r.Address Do i = r.Row If キーワードⅡ.Value = "" And キーワードⅢ.Value = "" Then With Me.一覧リスト .AddItem r.Parent.Name & vbTab & r.Address(False, False) .ColumnWidths = "80,0,40,20,60,150,150" .List(一覧リスト.ListCount - 1, 2) = ws.Cells(i, 10).Value .List(一覧リスト.ListCount - 1, 3) = ws.Cells(i, 2).Value End With End If If キーワードⅡ.Value <> "" And キーワードⅢ.Value = "" Then ws2 = r.Parent.Name For Each c In Worksheets(ws2).Range("A" & i & ":AC" & i) If InStr(c.Value, キーワードⅡ.Value) <> 0 Then With Me.一覧リスト .AddItem r.Parent.Name & vbTab & r.Address(False, False) .ColumnWidths = "80,0,40,20,60,150,150" .List(一覧リスト.ListCount - 1, 2) = ws.Cells(i, 10).Value .List(一覧リスト.ListCount - 1, 3) = ws.Cells(i, 2).Value End With End If Next c End If If キーワードⅡ.Value <> "" And キーワードⅢ.Value <> "" Then ws3 = r.Parent.Name For Each c In Worksheets(ws3).Range("A" & i & ":AC" & i) If InStr(c.Value, キーワードⅡ.Value) <> 0 Then For Each d In Worksheets(ws3).Range("A" & i & ":AC" & i) If InStr(d.Value, キーワードⅢ.Value) <> 0 Then With Me.一覧リスト .AddItem r.Parent.Name & vbTab & r.Address(False, False) .ColumnWidths = "80,0,40,20,60,150,150" .List(一覧リスト.ListCount - 1, 2) = ws.Cells(i, 10).Value .List(一覧リスト.ListCount - 1, 3) = ws.Cells(i, 2).Value End With End If Next d End If Next c End If Set r = ws.Cells.FindNext(r) Loop While Not r Is Nothing And r.Address <> fAddr End If Next 件数.Caption = 一覧リスト.ListCount If 一覧リスト.ListCount = 0 Then MsgBox "ﾃﾞｰﾀ内に一致するｷｰﾜｰﾄﾞはありません", vbExclamation, "Not Found" Exit Sub End If Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

tatsu99 · Accepted Answer

No2です。 No2のマクロが遅いので、作り直しました。こちらだと、マッチする件数が多くても、少なくても速くなります。（多い場合はそれなりに時間がかかりますが、No1よりは速いかと。少ない場合は、No1と同程度かと。）よかったら、試してください。 --------------------------------------- Private Sub 検索2_Click() Me.一覧リスト.Clear Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Me.キーワード検索.Value = "" Then Exit Sub If キーワードⅡ.Value = "" And キーワードⅢ.Value <> "" Then MsgBox "ｷｰﾜｰﾄﾞ2を入力してください。", vbOKOnly + vbInformation Exit Sub End If t1 = Now Set wsv = ActiveSheet w = Array("2016", "2017", "2018") For Each ws In Worksheets(w) ws.Activate ActiveCell.SpecialCells(xlLastCell).Select maxcol = ActiveCell.Column maxrow = ActiveCell.row If maxrow = 1 And maxcol = 1 Then maxcol = 2 End If cellAR = Range(Cells(1, 1), Cells(maxrow, maxcol)) For i = 1 To maxrow Find = findword(cellAR, i, maxcol, Me.キーワード検索.Value, findcol) If Find = True Then Address = ws.Cells(i, findcol).Address(False, False) If Me.キーワードⅡ.Value <> "" Then Find = findword(cellAR, i, maxcol, Me.キーワードⅡ.Value, findcol) If Find = True And Me.キーワードⅡ.Value <> "" Then Find = findword(cellAR, i, maxcol, Me.キーワードⅢ.Value, findcol) End If End If End If If Find = True Then With Me.一覧リスト .AddItem ws.Name & vbTab & Address .ColumnWidths = "80;0;40;20;60;150;150" .List(一覧リスト.ListCount - 1, 2) = ws.Cells(i, 10).Value .List(一覧リスト.ListCount - 1, 3) = ws.Cells(i, 2).Value End With End If Next i Next t2 = Now 時間.Caption = Second(t2 - t1) & "秒" 件数.Caption = 一覧リスト.ListCount If 一覧リスト.ListCount = 0 Then MsgBox "ﾃﾞｰﾀ内に一致するｷｰﾜｰﾄﾞはありません", vbExclamation, "Not Found" End If wsv.Activate Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Private Function findword(ByRef cellAR As Variant, ByVal row As Long, ByVal maxcol As Long, ByVal word As String, ByRef findcol) As Boolean For col = 1 To maxcol If cellAR(row, col) <> "" Then If InStr(1, cellAR(row, col), word, vbTextCompare) > 0 Then findword = True findcol = col Exit Function End If End If Next findword = False End Function

WindFaller · Answer

質問者のdayan-fan様。
元のdayan-fanさんのコードは、ループの検索で見つけた時点で、Exit Do や Goto などでループを抜け出れば、多少の時短は可能だと思いましたが、それ以上は、根本的に、全体を組み替えないと速くならないようです。または、列をそれぞれ指定して検索するようにしたほうがよいのではないかと思いました。

ツールの話はきりがありませんが、EXCELには不思議なツールがいくつかあります。長く携わるようでしたら、また一考かと思います。しかし、水面下では、Microsoft 側で、EXCEL VBAのカスタマイズ・ツール(例えば、リボン）は、Visual Studio 側にあるようです。

tatsu99様
分かってくださって、ありがとうございました。ご迷惑を掛けてすみません。私の発言は、Out of Rules です。削除対象でも構いません。私の場合は、書ける時に書かないと、もう届かなくなってしまうような気もして、アップしました。

以前は、ここの掲示板の中だけですが、横のつながりがあって、お互いが教え教わり、切磋琢磨した時代もあって、ここで多くを教わったのですが、だんだんと様変わりをしてしまいました。

MZ-Toolsの'MZ'は、マジンガーZにちなんで名付けられたもので、長いあいだ、フリーツールとして定評がありました。有償にしたのは、それほど古くはありません。まだ、Ver3. が、フリー番も手に入る可能性はあります。本当の便利なのは、マクロコードのテンプレートを格納できることです。それをショートカットで呼び出せます。Projects(複数のプロジェクト）検索も可能てす。

>定義した変数名がプロパティ名と一致していることの検知もできるのでしょうか？
そういう名目で出てきているのではないようです。MZでは、"Review Quality"の"Nomenclature Rules(命名ルール）"に準じていないとして出てきます。
警告の画面：

tatsu99 · Answer

質問者様へ
tatsu99です。
とりあえず、私の方はこのスレッドを閉じていただいて構いません。
ありがとうございました。

tatsu99 · Answer

WindFaller様
tatsu99です。
インデンター、MZ-Toolsの両方を試してみました。
自分でコーディングする場合は、特に必要ないのですが、gooのこのサイトに投稿されたコードを
検証する際は、インデントがついていると判りやすいので、確かに便利ですね。
MZ-Toolsの方は有料なので、当面はインデンターを使ってみます。
ツールの紹介ありがとうございました。

tatsu99 · Answer

WindFaller様
tatsu99です。
変数に、プロパティ名を使う件、参考になりました。
今後は、変数名を使用する際、プロパティ名は使用しないように心掛けたいと思います。
一点、教えていただきたいのですが、
照会されたツールの、インデンター、MZ-Toolsは、インデントの修正の他に、
定義した変数名がプロパティ名と一致していることの検知もできるのでしょうか？
単純にインデントのみの修正であれば、インデントの生成で不自由は感じていませんので、利用するつもりは
ないのですが、定義した変数名がプロパティ名と一致しているケースのチェックも行えるなら、
利用したいと考えています。

質問者様へ
本来、回答者同士のやりとりで、このスレッドを利用するのはマナー違反なので、しないようにしていますが、
今回、このような事態なので、利用させていただきました。ご了承ください。

tatsu99 · Answer

>頂いたコードを試しましたところ、一覧リスト上に下記の情報が表示されず、空欄になります。 
>.List(一覧リスト.ListCount - 1, 2) = ws.Cells(i, 10).Value
>.List(一覧リスト.ListCount - 1, 3) = ws.Cells(i, 2).Value

うーん。そういうことでしたか。
こちらでは、上記の情報はきちんと表示されています。

考えられるのは、
iの値が途中で書き換えられていることくらいです。
もし、あなたが、
for i = 1 To maxrow
・・・・・
next i
の・・・・の部分に何か追加した、変えたとかはされていないでしょうか。

念のため、
r=i
・・・
.List(一覧リスト.ListCount - 1, 2) = ws.Cells(r, 10).Value 
.List(一覧リスト.ListCount - 1, 3) = ws.Cells(r, 2).Value 
の直後に
if i <> r then
msgbox("r=" & r & " i=" & i)
End if
を追加してはいかがでしょうか。もし、メッセージボックスが表示されれば、途中でiが書き換えられていることになります。

WindFaller · Answer

スレ主さん、トピックオフで失礼します。

tatsu99様へ

いつも拝見させていただいております。
今回、変数について触れておりますので、ひとつだけ、貴方様のコードに心残りのものがあります。

それは、変数に、プロパティ名などを使っても、エクセルは、予約語としてはエラーを吐くことはありませんが、数年に一度ぐらいの質問の中に、プロパティが小文字となる現象を直したいという質問を見かけます。

貴方のコードで、
Dim row As Long としている場合がありますが、こういうコードで宣言すると、それは、プロジェクト全体に波及し、Range("A1").row となってしまいます。それで、トラブルというものはないにしても、人によっては、直したいという要望があります。

直す場合は、新たに、Dim Row として宣言して、それを消せば元に戻りますが。

Dim lRow 
Dim rw 
でも、よいので、直接のプロパティ名は避けたほうが良いと思います。
Dim col は、問題がありませんね。(<Column)

こちらで試す時は、必ず直すことにはしていますが、つい忘れることもありますので、もし理解していただけたら、その表記は直していただいたほうが良いかと思います。自分で使う分にはよいのですが、他人の環境に影響はなるべく与えないほうがよいからです。

他にも、ご存知だとは思いますが、変数やプロシージャ名に大文字・小文字を組み合わせたり、インデンターというツールを使って、インデントを付けたりして、ミスを減らすように心がけています。これは、かた苦しくなるので人にはオススメしませんが、私は、変数は、多少とも英語を意識しています。c は、Cells, r は、Range, i は、カウンター変数として　iteration(反復）とか、n は、number/nominal, xは、列の数字、yは、行の数字とか。原則的に、二文字以下の場合は、小文字です。定数は、大文字です。

インデンターというアドインツールは、
http://www.oaltd.co.uk/Indenter/Default.htm
2007以降も動きます。
私自身は、MZ-Tools というものを利用しています。
https://www.mztools.com/

気分を悪くされましたら、申し訳ありません。

tatsu99 · Answer

>Address = ws.Cells(i, findcol).Address(False, False)
>のコードの下に
>r=i
>と追加し、一覧リスト表示のCellsのiをrに変更したところ、見かけ上は表示できるようになったかと思うのですが、
>自信がありません。

iをrにしたいということでしょうか。
そうであれば
for i = 1 to maxrow
・・・・
・・・・
next i
を
for r = 1 to maxrow
・・・・
・・・・
next r
にして、・・・・の箇所のiを全てrにすればOKです。
もし、なさりたいことが違っていたら、その旨返信ください。
----------------------------------------------------------
ところで、老婆心ながら、おすすめしますが、マクロの先頭行に
Option Explicit
を付けることをお勧めします。
そうすることにより変数の宣言が強制されるの、スペルミスによる間違いを、かなり減らすことができるようになります。
また、変数の宣言をすることにより、型の意識も行えるようになります。
例えば、今回の　i は整数型なので
dim i as long
のようにします。
もし、型が判らなければ取り合えず、
dim x
のように書いておいても構いません。

WindFaller · Answer

少し、私もコメントを残しておきます。一応、コード読み切りましたが、言わずもがなかもしれませんが、これは、UserForm によって作られたコードのように見受けられますが、それは一切書かれていません。Active X コントロールの可能性もありますので、最初に書いていただけたら良かったと思います。UserFormを前提にさせていただきます。 Me.一覧リストの .ColumnWidths = "80,0,40,20,60,150,150" は、予めプロパティで設定しておくか、 UserForm_Initialize() で、当てはめればよいと思います。検索がヒットしたたびごとに、オブジェクトをいじっていれば、遅くなる原因のひとつでしょう。 ColumnCount は7 なのでしょうか？でも、使わないカラムなら、設定は不要だと思います。なお、実際、リストボックスを使わないで、ワークシートに表を設けて、そこでリスト化すれば速かっただろうに、と思います。今のご質問の前提を崩してしまうことになりますし、そもそも、これはデータベースなのですから、エクセルのデータベース型検索(例えば、AdvancedFilter)にすれば、いくら多くのデータでも、ストレス・フリーで検索できます。コードも単純に済みます。複合検索の場合は、フィールド(エクセルでは列）を指定して検索するのが確実だと思います。キーワード検索(TextBox) は、会社名とか。キーワードⅡ(TextBox)は、会社名より右にあるものとか。No.3のママチャリさんのアイデアは、それ良いかもしれません。しかし、FindNext のところで、方向を変えてしまうと、ループでは、元に戻れなかった記憶があります。間違いかもしれませんが。 >そこで、同じ行で複数一致した場合でも、リストに表示するのは1件のみ表示という風にすることはできませんでしょうか？これについては、コードのミスがあるようですね。見つけた後、ループから抜け出す方法がないから、最後までループし続けています。考え方は良く分かるけれども、 For Each c In Worksheets(ws3).Range("A" & i & ":AC" & i) 　If InStr(c.Value, キーワードⅡ.Value) <> 0 Then 　 For Each d In Worksheets(ws3).Range("A" & i & ":AC" & i) 　　If InStr(d.Value, キーワードⅢ.Value) <> 0 Then 1行には、1回見つければよいものを、ループしているので、見つけた後も検索していますから、途中で、Exit for で抜けなくてはならないのですが、これが、For Each ✕2なので、Goto を使って抜け出なくてはなりませんね。私のマクロのお約束は、検索語のフィールドは特定できませんが、順序がありますから、 A,B,C と3つの検索語の場合は、Aで見つからない場合は、次はありません。Bが見つからない場合は、Cはありません。これは、対話型のMsgBox は付いておりません。 '//UserFormモジュール Private Sub UserForm_Initialize() With Me.一覧リスト　 .ColumnCount = 7 　 .ColumnWidths = "80,80,80,20,60,150,150" 　 ' .ColumnWidths = "80,0,40,20,60,150,150" '元のコードから End With End Sub Private Sub 検索_Click() Dim c As Range Dim arSrch() As Variant Dim sh As Worksheet Dim k As Long, i As Long Dim FirstAddress As String If Me.キーワード検索.Value = "" Then Exit Sub ReDim Preserve arSrch(0) arSrch(0) = Me.キーワード検索.Value If Me.キーワードⅡ.Value <> "" Then 　ReDim Preserve arSrch(1) 　arSrch(1) = Me.キーワードⅡ.Value '2byte文字の名前は、ループが利かない End If If Me.キーワードⅢ.Value <> "" Then 　ReDim Preserve arSrch(2) 　arSrch(2) = Me.キーワードⅢ.Value End If '------------------- For Each sh In Worksheets 　If Val(sh.Name) >= 2016 And Val(sh.Name) <= 2018 Then 　 With sh.Cells 　　Set c = .Find(What:=Me.キーワード検索.Value, LookAt:=xlPart, MatchCase:=False, MatchByte:=False, LookIn:=xlValues) 　　If Not c Is Nothing Then 　　 FirstAddress = c.Address(0, 0, , True) 　　 Do 　　　If SecondSearch(c, arSrch) Then 　　　 With Me.一覧リスト　　　　.AddItem sh.Name & vbTab & c.Address(0, 0) 　　　　.List(一覧リスト.ListCount - 1, 2) = c.EntireRow.Cells(10).Value 　　　　.List(一覧リスト.ListCount - 1, 3) = c.EntireRow.Cells(2).Value 　　　 End With 　　　End If 　　　Set c = .FindNext(c) ' 　　　If c.Address(0, 0, , True) = FirstAddress Then Exit Do 　　 Loop Until c Is Nothing 　　End If 　 End With 　End If 　FirstAddress = "" Next sh End Sub Function SecondSearch(c As Range, arSrch As Variant) As Boolean Dim i As Long, j As Long, k As Long Dim r As Range Dim col As Long Dim rng As Range j = 0 Set rng = c.Offset(, 1).Resize(, 29 - c.Column) For i = j To rng.Columns.Count 　k = InStr(1, rng.Cells(i).Value, arSrch(j), vbTextCompare) 　If k > 0 Then 　 If UBound(arSrch) > j Then 　 j = j + 1 　 k = 0 　 Else 　 Exit For 　 End If 　End If Next i If k > 0 Then 　SecondSearch = True End If End Function

tatsu99 · Answer

No2です。

No2のマクロは、マッチする件数が少ない場合、No1より遅くなります。
その為、No1を採用したほうが良いですね。
No1のマクロの
Findの指定をみると、大文字小文字を区別しない、全角半角を区別しないで検索しています。
従って、その条件で検索する前提です。

instrをみると大文字小文字を区別する、全角半角を区別するで検索しています。
If InStr(c.Value, キーワードⅡ.Value) <> 0 Then
を
If InStr(1,c.Value, キーワードⅡ.Value,vbTextCompare) <> 0 Then
に変えてください。そうすると、大文字小文字を区別しない、全角半角を区別しないで検索します。

他のinstrも同様です。

検索結果の一覧リストの表示について【Excel2010 VBA】

No2です。

質問者のdayan-fan様。

質問者様へ

WindFaller様

WindFaller様

>頂いたコードを試しましたところ、一覧リスト上に下記の情報が表示されず、空欄になります。

スレ主さん、トピックオフで失礼します。

>Address = ws.Cells(i, findcol).Address(False, False)

少し、私もコメントを残しておきます。

No2です。

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

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

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

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