ユーザーフォームを使って文字を検索→リストに表示→指定したセルへ貼り付け

質問

現在、家紋の詳細を表したプリントを作っています。これはあらかじめ入力しておいた"由来・かつてその家紋を使ってきた武将”などをお客さんの家の家紋を聞いて家紋名を入力したら、その由来や武将が出てくるようにしています。しかし、家紋名を正しく入力しなければマクロで探しだすことができません。この家紋の種類が3000種以上あり、家紋名の一覧からお客さんの家紋を探すのが大変です。
ここで、私の理想とするのは、例えば、「源氏輪に揚羽蝶」という家紋名を入力したいとする。ユーザーフォームのテキストボックスに「源氏(スペース)蝶」と入力すれば、ダウンリストで、「源氏輪に揚羽蝶」や「源氏蝶」が出てきて、、「源氏輪に揚羽蝶」の方をクリック。そしたら指定したセル（D2)へ入力される。
こういった流れです。過去にこれを関数と入力規則のリスト表示で教えて頂きました。かなり使わせてもらったのですが、リストの表示が小さく見えにくいという問題があります。
わかる方ご教授願います。

回答No.5

Wendy02

こんばんは。

>わからないことがあったら連絡させていただいていいでしょうか？
今は、先が見えないこともありますが、なるべく、ここはチェックするようにしています。また、ここの質問を開けておいて、「お礼」側に付けてくだされば、メールが届きますので、ここを続けている限りは、それでも構いません。

まだ、いろいろ考えてはいます。今回のは、私自身としては、この種類のものは、ずっと引っかかっていたので、気にしていました。最近、Web 検索のツールなどをみて、あまり表示は速くなくても、もっと柔軟な検索ができているようです。

それと、もうひとつは、データベースの「FileMaker」を応用する方法はないか考えました。前にも書きましたが、そういう検索は、MS-DOSの時代からあるのです。それが、なぜ、今、Excelのような表計算でしかないのか、という素朴な疑問です。もちろん、Accessという安価なデータベースは手に入れやすいのですが、それにしても、あまり、思うようにはいかないように思います。

回答No.4

Wendy02

こんばんは。

大変、遅くなりました。私の中に、イメージがやっと沸いてきたのですが、以下のように作り変えてみました。

イメージコンボというのは、試してみたのですが、うまく行かないようです。
そこで、直接、イメージに出すことに決めてしまいました。

UserForm にイメージ(Image )というのをひとつ設けてください。
ピクチャー(Picture) を、そこに呼び出します。

次に、jpg などの外部ファイルですが、今は、C列に直接書いてあります。

家紋名
Set rng = Range("B1", Range("B65536").End(xlUp))
ここから、ふたつ目ということで、B列-1, C列-2 と数えます。
fn = rng.Cells(i, 2).Value

もし、M列でしたら、fn = rng.Cells(i, 11).Value　となります。

検索値は、スペースを区切れば、何個でもよいです。
ただし見つからなければ、「見つかりません」とメッセージボックスが出てきます。
---------------------------------------------------------

Private Datas() As Variant

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim rng As Range
Dim fn As String
Set rng = Range("B1", Range("B65536").End(xlUp))
　i = WorksheetFunction.Match(ComboBox1.Value, rng, 0)
　fn = rng.Cells(i, 2).Value
　If fn <> "" Then
　With UserForm1
　　　.Image1.Picture = LoadPicture(fn)
　　　.Image1.PictureSizeMode = fmPictureSizeModeZoom
　　　.Show (False)
　End With
　End If
　Set rng = Nothing
End Sub

Private Sub CommandButton1_Click()
　　Dim ar As Variant
　　Dim sText As String
　　Dim arT As Variant
　　Dim sWords As Variant
　　On Error GoTo ErrHandler
　　dummy = Datas(0)
　　On Error GoTo 0
　　With ActiveSheet
　　　　If .Range("D1").Value <> "" Then
　　　　　　sText = Replace(.Range("D1").Value, Space(1), Space(1), , , vbTextCompare)
　　　　　　sWord = Split(Trim(sText), Space(1))
　　　　　　arT = Datas
　　　　　　For i = LBound(sWord) To UBound(sWord)
　　　　　　　　ar = Filter(arT, Trim(sWord(i)))
　　　　　　　　If UBound(ar) > -1 Then
　　　　　　　　　　arT = ar
　　　　　　　　End If
　　　　　　Next i

　　　　　　j = UBound(ar, 1)
　　　　　　If j < 0 Then
　　　　　　　　MsgBox "検索値は見つかりません。", 64
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　.ComboBox1.Clear
　　　　　　.ComboBox1.List = arT
　　　　End If
　　End With
　　Exit Sub
ErrHandler:
　　Call MakingDatas
　　Resume Next
End Sub
Private Sub MakingDatas()
Dim rng As Range
　　Dim arRng As Variant
　　Dim ListCount As Long
　　Dim i As Long
　　With ActiveSheet
　　　　Set rng = .Range("B1", .Range("B65536").End(xlUp))
　　　　arRng = rng.Value
　　　　ListCount = rng.Rows.Count
　　　　ReDim Datas(ListCount - 1)
　　　　For i = 1 To ListCount
　　　　　　Datas(i - 1) = arRng(i, 1) '１次元切り替え
　　　　Next i
　　　　Set rng = Nothing
　　End With
End Sub

お礼

連絡が遅れてすいませんでした。いろいろとありがとうございました。私も、イメージで画像を出す方法を考えていました。Wendy02さんに作っていいただいたものを現在自分が作ったマクロとを組み合わせています。自分の力量では時間がかかりそうですが、自分なりに試行錯誤してマスターしたいと思います。また、わからないことがあったら連絡させていただいていいでしょうか？よろしくお願いします。

回答No.3

Wendy02

直接の回答ではありませんが、

>それでは、またお願いしていいでしょうか？

それは、大丈夫です。面白そうというか、正直なところ、Excelでは、ちょっと厳しいなって思うのです。誰かが、あっというような方法で解決させてしまいそうな気もしますが、ためしに作ってみて、自分の中のイメージと、nicedesuさんのやっておられることと、それほどギャップはなさそうですので、続けられそうです。

ご自身でやっていくのは大変かとは思いますが、何とか、私のほうとしては、なるべく早い段階で作り上げたいと思います。

書き込みは不定期になりそうなので、「お礼」側に、ちょっとコメントを入れていただければ、助かります。そうすると、こちらには直接メールが入りますので、すぐに分かります。とりあえずは、きちんとした返事はつけておりませんが、失礼します。

回答No.2

Wendy02

こんばんは。

おそくなりました。私は、この種の質問では、投げたりしませんから、ご安心ください。必ず、最後まで仕上げます。しかし、私のイメージで暖めているものとは、かなり違った内容ですので、、試行錯誤するので、途中で、まったく違った方針に換える可能性があることは、あらかじめ申しておきます。

また、必ずしも、今までのやってきたものをそのまま生かすということはしないかもしれません。

>印刷」というコードは家紋の画像を挿入させるマクロの名前です。
家紋の画像は、どのような状態に置かれていますか？
それによって呼び出し方が変わります。

それはともかく、まず、前回の抽出の部分から手をつけたいと思っています。前の回答された方には申し訳ないのですが、こちらで新たに作ります。

ダウンリストを使って文字検索
http://oshiete1.goo.ne.jp/qa3356739.html

>H1の入力規則でのダウンリスト

これを、コンボボックスには換えられませんか？
今は、入力規則の代わりにコンボボックスを置きました。

コントロールツールのコマンドボタン
　　　　　　　　　　コンボボックス

D1 に検索文字　を入れます。
入れ方は、
「三　葉」　（スペースで区切ります）
と入れると、

三つ葉葵
三つ葉桔梗
三つ葉菊

今の段階では、２つまでです。ご希望にしたがって、これは、数を増やすことができます。3000個の中から、この程度の絞りきることが可能なら、いろんな方法が考えられます。まだ、私は、見えていない部分があるので、あまり先走りたくありませんが、私の中で考えていた検索の手法です。

なお、これは、UserFormに移行可能です。

また、できるのかどうかはわかりませんが、イメージコンボボックスというものがあります。

http://www.microsoft.com/japan/msdn/vbasic/migration/tips/ImageComboBox/

サンプル私案：

シートモジュール
-------------------------------------------------------

Private Datas() As Variant
Private Sub CommandButton1_Click()
　　Dim ar As Variant
　　Dim ar2() As Variant
　　Dim sWords As Variant
　　On Error GoTo ErrHandler
　　dummy = Datas(0)
　　On Error GoTo 0
　　With ActiveSheet
　　If .Range("D1").Value <> "" Then
　　　　sWord = Split(Trim(.Range("D1").Value), Space(1))
　　　　ar = Filter(Datas, Trim(sWord(0)))
　　　　.ComboBox1.Clear
　　　　.ComboBox1.List = ar
　　End If
　　If UBound(sWord) = 1 Then
　　　　ar = .ComboBox1.List
　　　　j = UBound(ar, 1)
　　　　ReDim ar2(j)
　　　　For i = 0 To j
　　　　　ar2(i) = ar(i, 0)
　　　　Next i
　　　　ar = Filter(ar2, Trim(sWord(1)))
　　　　.ComboBox1.Clear
　　　　.ComboBox1.List = ar
　　End If
　　End With
　　Exit Sub
ErrHandler:
　　Call MakingDatas
　　Resume Next
End Sub
Private Sub MakingDatas()
Dim rng As Range
　　Dim arRng As Variant
　　Dim ListCount As Long
　　Dim i As Long
　　With ActiveSheet
　　　　Set rng = .Range("B1", .Range("B65536").End(xlUp))
　　　　arRng = rng.Value
　　　　ListCount = rng.Rows.Count
　　　　ReDim Datas(ListCount - 1)
　　　　For i = 1 To ListCount
　　　　　　Datas(i - 1) = arRng(i, 1) '１次元切り替え
　　　　Next i
　　　　Set rng = Nothing
　　End With
End Sub

補足

ありがとうございます。早速、試してみました。新しくシートを作ってやってみたら、ちゃんとなりました。
まず、質問に回答します。
＞家紋の画像は、どのような状態に置かれていますか？
同一フォルダで画像はEMFファイルです。
ちなみにコードは以下のとおりです。
Sub 印刷()
シート保護解除
Dim sh As Picture, fName As String
Dim sh2 As Picture, gName As String
fName = "D:\kamondata\" & "\" & Range("F2").Value
Application.ScreenUpdating = False
With Worksheets("印刷")
ActiveSheet.Pictures.Delete
Set sh = .Pictures.Insert(fName)
sh.Left = .Cells(12, 4).Offset(0, 0).Left
sh.Top = .Cells(12, 4).Offset(0, 0).Top
sh.ShapeRange.LockAspectRatio = msoFalse
If Range("G2").Value = "B" Then
sh.ShapeRange.LockAspectRatio = msoTrue
sh.ShapeRange.IncrementTop 19#
End If
sh.ShapeRange.Height = 225
If Range("G2").Value = "D" Then
sh.ShapeRange.Width = 100
sh.ShapeRange.IncrementLeft 112#
Else
　　　　　　　　　　：
　　　　　　　　　　：
’このようにA～Hまでパターンが続きます。文字数オーバーのため省略します。

End If
For i = 2 To 6 Step 2
On Error Resume Next
gName = "D:\kamondata\" & "\" & Cells(66, i).Value
Application.ScreenUpdating = False
Set r = Cells(65, i)
If r = 0 Then
Exit Sub
End If
Set sh2 = .Pictures.Insert(gName)
sh2.Left = .Cells(57, i).Offset(0, 0).Left
sh2.Top = .Cells(57, i).Offset(0, 0).Top
sh2.ShapeRange.LockAspectRatio = msoFalse

'ここで上でやったパターンでの条件貼り付けコードが入ります。
Next i
End With
シート保護
End Sub

EMFのファイルの縦横の比率がバラバラだったので、A～Hでパターンを変えて貼り付けるようにしています。それぞれパターンはファイル名の横列に並べています。

＞これを、コンボボックスには換えられませんか？
私もできればそうしたいと思っていました。
＞今の段階では、２つまでです。
２つできれば絞れそうです。多くても10～15個くらいリストに出てくるようなので、その中から選ぶのはそんなに大変ではありませんでした。

＞イメージコンボボックスというものがあります。
参考に見てみたのですが、かなり魅力的です。家紋の図が横に出てきて、その中から選べれば、かなり効率があがりそうです。挑戦してみたいです。

それでは、またお願いしていいでしょうか？

回答No.1

Wendy02

こんばんは。

私は、「ある重複する文字列を抽出したいのですが」で回答を差し上げた者です。

なかなかレスがつかないようですが、このご質問、しばらく、いろんなことを考えてみました。
一部、直接、回答とは関係がないことを書くことをお許しください。

このご質問は、カード型のデータベースの範囲ですね。MS-DOS時代は、そのスタイルはお馴染みだったのに、今は、うまくいかない（レスがつかない）というのは、どこか、技術の進歩が形だけのような気がしてくるのです。もちろん、Excelのユーザーフォームでも可能ですが、もっと簡単にできないのかなって思い、釈然としない気持ちがわいてきてしまいました。

私の頭の中の組み立てでは、その解決方法は、そんなに簡単とはいえないからです。

また、上記の「ある重複する文字列...」の解決方法も、私も回答を書いた一人として、あまり簡単とはいえませんね。

閑話休題。

Accessでしょうか、Excelでしょうか？

いままでのご質問からするとExcelのようでもあるのですが、いずれにしても、まず、名称とファイル名は一致していなければいけませんね。画像ファイルとリンクする必要はありません。リンクしたりすると、処理が逆に面倒になってしまいます。

>リストの表示が小さく見えにくいという問題があります。
リストは、フォント・サイズを変えればよいです。

>「源氏(スペース)蝶」と入力すれば、ダウンリストで、「源氏輪に揚羽蝶」や「源氏蝶」が出てきて、

List を使います。ただ、そのList に表示するのも、私の考えの中では配列を使います。
List は、どこにあるのでしょうか？ワークシートですか？

少し、サンプルを出していただけるとありがたいのですが。
まず、検索プログラムから出発することにします。

少し、手間がかかりそうな気がします。

もし、ある程度、土台が出来上がったら、そのコードで、専門掲示板でお尋ねになってもよいと思います。いきなり質問すると、情け容赦なく手厳しく怒られることがあります。ここの掲示板は、乱暴な人がいない代わりに、種々雑多で、最終的な回答者が個人に集約されてしまいます。あまりよいアイデアに恵まれないこともあります。なかなか、思うようには回答がつかないこともあります。

私の場合の回答の有効範囲は、だいたい1ヶ月です。延長すれば、60日というように、Excelのシステムで自分の発言を管理しています。ただし、気が乗ればという条件付きです。（^^;

私個人は、ここの掲示板だけですが、中には、専門掲示板で半年以上掛けて、システムを構築している人を見かけます。コードはつぎはぎだらけですが、不思議と形になっているのです。そういう人もいますから、気長に製作することをお勧めします。

補足

ありがとうございます。「ある重複する文字列を抽出したいのですが」の質問では大変助かりました。また、この質問は無理かなと諦めかけていました。それで自分なりにやってみたコードもあるので後ほど書きます。
その前にWendy02さんからの質問に答えさせてもらいます。
＞Accessでしょうか、Excelでしょうか？
Excelです。
＞List は、どこにあるのでしょうか？ワークシートですか？
同一ブックの別シートにあります。

以下はをhttp://oshiete1.goo.ne.jp/qa3356739.htmlのmaron--5さんの回答を参考に自分なりにやったものです。

●Sheet3のワークシートでの作業
A列には1から3254の数字。D列には家紋の名前が3254個並んでいます。
C1に=IF(COUNTIF(D1,"*"&$G$1&"*"),ROW(),"")という関数が入り、これをC3254までコピーしてます。
K1に=IF(ROW(C1)>COUNT(C:C),"",INDEX(D:D,SMALL(C:C,ROW(C1))))という関数で同じく3254行までコピーしてます。
定義の中に「抽出」と題して=OFFSET(Sheet3!$K$1,,,COUNTIF(Sheet3!$K$1:$K$99,">*"))を作り、H1の入力規則でのダウンリストで定義を貼り付けています。つまり、G1に探したい名前の1部を入力したら、H1にリストが出てくるという関数です。

ここからはユーザーフォームです。
ユーザーフォームでは先ほどのSheet3のG1にテキストボックスから入力し、コマンドボックスでK列を参照するように作りました。ここで選んだ下問の名前を"印刷"というシートのD2に入れるようにしています。

■UserForm3にテキストボックスとコマンドボタン２つを作って下のコード
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub CommandButton1_Click()
Worksheets("Sheet3").Cells(1, 7) = UserForm3.TextBox1.Value
Worksheets("印刷").Cells(2, 4).Select
UserForm4.Show
Unload Me
End Sub
Private Sub UserForm_Initialize()
TextBox1.IMEMode = fmIMEModeHiragana
End Sub

■UserForm4にコマンドボックスとコマンドボタンを作って下のコード
少しまぎらわしいですが、「印刷」というコードは家紋の画像を挿入させるマクロの名前です。

Private Sub CommandButton1_Click()
印刷
Unload Me
End Sub

Private Sub UserForm_Click()

End Sub
Private Sub UserForm_Initialize()

Dim i As Integer
With Worksheets("sheet3")
For i = 1 To 50
Me.ComboBox1.AddItem Worksheets("sheet3").Cells(i, 11).Value
Next i
Me.ComboBox1.Style = fmStyleDropDownList
End With
ComboBox1.IMEMode = fmIMEModeHiragana
End Sub

Private Sub ComboBox1_Change()
シート保護解除
Worksheets("印刷").Range("D2").Value = ComboBox1.Text
シート保護
End Sub

ひとつのユーザーフォームでテキストボックスとコマンドボックスを作ってやっていましたが、コマンドボックスに表示されるのが、前回テキストに入力されたものが出てきてしまうので、２つに分けて作りました。
まだまだ、わからないことばかりで、説明もうまくできませんが、自分が納得できるものを作りたいと思っています。よければ、ご教授お願いします。