[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ユーザーフォームで検索ツールを作ったのですが。。。』（ytake）
教えてください。
初心者です。ネットでひろいながら、自分自身の仕様に合わせて
検索ユーザーフォームを作ってみました。
検索ワードで抽出されたものが、きちんとリストボックスに表示されたは
いいのですが、
リストボックスに出たものの中から選んでダブルクリックすると、
その行のA列のセルにカーソルが移動するようにしたいのですが、
できません。（ListBox1)
ついでに、ダブルクリックしたときに
Aの列のセルの値をコピー（ハードコピー）して、
msgboxで、"ナンバーをコピーしました"と出したいのですが
作動いたしません。
ご教示いただけたらと存じます。
作った検索ユーザーフォームと
ListBox1のコードは以下となります。
★検索ユーザーフォーム
Private Sub CommandButton1_Click()
'検索ボタンをクリックしたときの処理
Dim i As Long
Dim Mydata As Variant
Dim LastRow As Long
Dim Cnt As Long
'配列カウント初期化
Cnt = 1
'最終行を取得
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
'2次元配列の要素数を変更TOは幅のほう
ReDim Mydata(1 To LastRow, 1 To 7)
'1行目〜最終行までループ
For i = 1 To LastRow
'E列に該当データがあったら
If Cells(i, 5) = Me.TextBox1.Text Then
'配列にA〜H列の値
Mydata(Cnt, 1) = "宛先No." & i - 1
Mydata(Cnt, 2) = Cells(i, 3)
Mydata(Cnt, 3) = Cells(i, 4)
Mydata(Cnt, 4) = Cells(i, 5)
Mydata(Cnt, 5) = Cells(i, 6)
Mydata(Cnt, 6) = Cells(i, 7)
Mydata(Cnt, 7) = Cells(i, 8)
Cnt = Cnt + 1
End If
Next i
'検索で一致したデータをリストボックスに表示（幅のほう）
With ListBox1
.ColumnCount = 7
.ColumnWidths = "50;120;60;90;50;50;30"
.List = Mydata
End With
End Sub
★ListBox1のコード（こちらがうまくいかないコードです）
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim fd_Cell
Set fd_Cell = Cells.Find(What:=ListBox1.Text, LookAt:=xlWhole)
fd_Cell.Select
Cells(2, "A") = ListBox1.Text
MsgBox "ナンバーをコピーしました"
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows11 ＞
https://www.moug.net/tech/exvba/0050116.html
https://www.moug.net/tech/exvba/0050163.html
（知らんけど） 2023/04/14(金) 23:42:31
こんな感じでどうでしょう？
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim s As String
Dim rng As Range
Static cb As DataObject
If cb Is Nothing Then Set cb = New DataObject
With Me.ListBox1
If .ListIndex >= 0 Then
s = .List(.ListIndex, 0) '1列目=0、2列目=1...
End If
End With
If s <> "" Then
Set rng = Me.ufFind(s)
If Not rng Is Nothing Then
If rng.Count > 1 Then
MsgBox "複数候補が見つかりました。値をコピーせずに対象範囲を選択します"
rng.Select
Else
cb.SetText rng.Value
cb.PutInClipboard
MsgBox "値をコピーして、セルを選択しました"
rng.Select
End If
Unload Me
Else
MsgBox "見つかりませんでした"
End If
End If
End Sub
Function ufFind(s As String) As Range
Dim f As Range
Dim ans As Range
Dim adr As String
With Cells
Set f = .Find(s, .Item(1), xlValues, xlWhole, xlByRows, False, False, False)
If Not f Is Nothing Then
Set ans = f
adr = f.Address
Do
Set f = .FindNext(f)
Debug.Print f.Address(0, 0)
If f.Address = adr Then
Exit Do
Else
Set ans = Union(ans, f)
End If
Loop
End If
End With
Set ufFind = ans
End Function
（稲葉） 2023/04/15(土) 06:25:19
稲葉さんが記載くださったものを見て感動いたしました。
ありがとうございます。
自分の仕様に合わせたのですが、
最後どうしても、わからないところがあります。
複数の検索結果があったときも、ひとつしかなかったときも
「ひとつしかなかった」ときに行いたい動作（宛先番号をコピーしましたのメッセージと、
クリップボードコピーと、選んだセルの選択）に仕様変更したく、
頂いたコードでちょこちょこ変更してみたのですが、
検索結果が１つしかなかった場合と
複数の検索結果があった場合の１行目をダブルクリックしても
反応しません。
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim s As String
Dim rng As Range
Static cb As DataObject
If cb Is Nothing Then Set cb = New DataObject
With Me.ListBox1
If .ListIndex >= 1 Then
s = .List(.ListIndex, 0) '1列目=0、2列目=1...
End If
End With
If s <> "" Then
Set rng = Me.ufFind(s)
If Not rng Is Nothing Then
If rng.Count >= 1 Then
rng.Select
cb.SetText rng.Value
cb.PutInClipboard
MsgBox "宛先番号をコピーしました"
Else
rng.Select
cb.SetText rng.Value
cb.PutInClipboard
MsgBox "宛先番号をコピーしました"
End If
End If
End If
End Sub
Function ufFind(s As String) As Range
Dim f As Range
Dim ans As Range
Dim adr As String
With Cells
Set f = .Find(s, .Item(1), xlValues, xlWhole, xlByRows, False, False, False)
If Not f Is Nothing Then
Set ans = f
adr = f.Address
Do
Set f = .FindNext(f)
Debug.Print f.Address(0, 0)
If f.Address = adr Then
Exit Do
Else
Set ans = Union(ans, f)
End If
Loop
End If
End With
Set ufFind = ans
End Function
（ytake） 2023/04/15(土) 12:21:46
デバッグしてどこがどうなってしまうのか調べてみてください 自分の仕様がなんなのか分からないです。 （稲葉） 2023/04/15(土) 13:01:52
今日は、全国的に雨なのだろうか...さて久しぶりに リストボックスのお勉強会に参加です。(笑)
＞配列にA〜H列の値 とあるが...CommandButton1_Click時の意味が不明ですが
'配列にA〜H列の値 Mydata(Cnt, 1) = "宛先No." & i - 1 Mydata(Cnt, 2) = Cells(i, 3) ←ここ不明
Cells(i, 2)が無いのはどうしてなのでしょうか？
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
〜 略 〜
Cells(2, "A") = ListBox1.Text ←ここもちょっとわからないですが
〜 略 〜
End Sub
◆元データ(Sheet1)とする
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H]
[1]|No. |郵便番号|住所 |名前 |性別|年齢|血液型|携帯電話
[2]|宛先No.1|257-0013|神奈川県|横山由佳 |女 | 49|B |8095770416
[3]|宛先No.2|534-0022|大阪府 |若林一仁 |男 | 35|O |8094989711
[4]|宛先No.3|638-0042|奈良県 |大高心和 |女 | 26|AB |9062336866
[5]|宛先No.4|560-0052|大阪府 |土谷幹男 |男 | 49|B |9011345482
[6]|宛先No.5|939-8216|富山県 |小山田夏音|女 | 50|O |9098795515
◆流れ
・ユーザーフォーム表示 ・テキストボックスにE列の検索値を入力 ( 上記の場合は「女」と仮に検索する ) ・リストボックスへ 宛先No.1、宛先No.3、宛先No.5 の行が入る ・宛先No.5 をダブルクリックする ・シート(Sheet1)のA6セル が選択される ・別シート(Sheet2)に下記のように、選択した1行の情報がコピーされる
|[A] |[B] |[C] |[D] |[E]|[F]|[G]|[H]
[1]|宛先No.5|939-8216|富山県|小山田夏音|女 | 50|O |9098795515
・ユーザーフォームを閉じる ( 終了 )
因みに、検索値が無い場合は、IFで分岐して リストボックスに「検索データが見つかりません」と.ColumnWidths の幅の広い所へ表示させる .ColumnWidths の幅は適当に変更してあります。
Private Sub CommandButton1_Click()
Dim Mydata As Variant
Dim i As Long, j As Long
Dim cnt As Long, LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Mydata(1 To LastRow, 1 To 8)
cnt = 1
For i = 1 To LastRow
If Cells(i, 5) = Me.TextBox1.Text Then
For j = 2 To 8
Mydata(cnt, 1) = "宛先No." & i - 1 '' 必要なら？
Mydata(cnt, j) = Cells(i, j)
Next j
cnt = cnt + 1
ElseIf cnt = 1 Then
Mydata(cnt, 3) = "検索データが見つかりません"
End If
Next i
With ListBox1
.ColumnCount = 8
.ColumnWidths = "50;50;120;80;30;30;30;70"
.List = Mydata
End With
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim fd_Cell As Range
Dim data As Variant
Set fd_Cell = Cells.Find(What:=ListBox1.Text, LookIn:=xlValues, LookAt:=xlWhole)
fd_Cell.Select
data = Range("A" & ActiveCell.Row).Resize(1, 8)
With Sheets(2)
.Range("A1:H1") = data
.Columns("A:H").AutoFit
End With
MsgBox ListBox1.Text & " をコピーしました"
Unload Me
End Sub
※動作の勘違いをしていたら、ごめんなさい。お勉強終了
※個人情報は、疑似個人情報生成サービスを使用しております。 https://hogehoge.tk/personal/
（あみな） 2023/04/15(土) 15:09:35
コピーってそういうことなのか・・・ 私が仕様勘違いしてたので、破棄してください。すみません。 （稲葉） 2023/04/15(土) 16:49:02
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.