Ｐａｇｅ 187 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼名前のFind.で同じ名前があった場合 １２３ 02/10/8(火) 11:34 ┗Re:名前のFind.で同じ名前があった場合 ichinose 02/10/9(水) 9:55 ┗Re:名前のFind.で同じ名前があった場合 １２３ 02/10/9(水) 11:33 ┗Re:名前のFind.で同じ名前があった場合 ichinose 02/10/9(水) 15:32 ┣Re:名前のFind.で同じ名前があった場合 １２３ 02/10/9(水) 17:14 ┗Re:名前のFind.で同じ名前があった場合 １２３ 02/10/9(水) 18:44 ┗リストボックスでも追加しましょうか ichinose 02/10/9(水) 23:45 ┗Re:凄すぎです。 １２３ 02/10/10(木) 10:44 ┗Re:凄すぎです。 ichinose 02/10/10(木) 13:30 ┗Re:あまりにも完璧すぎです 会社員 02/10/10(木) 15:24 ┗Re:あまりにも完璧すぎです（訂正とお詫び） １２３ 02/10/10(木) 15:34 ─────────────────────────────────────── ■題名 ： 名前のFind.で同じ名前があった場合 ■名前 ： １２３ ■日付 ： 02/10/8(火) 11:34 -------------------------------------------------------------------------
| いつも お世話になっております。 実は、Find.で氏名を検索してExcelシートデータを ユーザーフォームに表示させていますが、 同じ名前があると、氏名_Exit では、一番上にあるデータ に戻ってしまいます。 解決策はあるでしょうか。 また、同じ名前があった場合の処理をさせることができるものでしょうか。 どなたか お助けください。 Private Sub 氏名_Exit(ByVal Cancel As MSForms.ReturnBoolean) smi = 氏名.Value If 氏名.Value = "" Then Exit Sub Else Dim Find_1 As Range With ActiveSheet Set Find_1 = .Range(.Cells(2, 6), .Cells(3000, 6)).Find(smi) If Find_1 Is Nothing Then コメント.Value = smi & " は見つかりませんでした。入力し直して下さい。" 会社名.Value = Empty 部署.Value = Empty グループ名.Value = Empty 役職.Value = Empty 資格.Value = Empty 氏名.Value = Empty カナ.Value = Empty 郵便番号.Value = Empty 住所.Value = Empty 電話番号.Value = Empty 氏名.SetFocus Exit Sub End If Find_1.Activate Cells(ActiveCell.Row, 1).Select 会社名.Value = ActiveCell.Value 部署.Value = ActiveCell.Offset(0, 1).Value グループ名.Value = ActiveCell.Offset(0, 2).Value 役職.Value = ActiveCell.Offset(0, 3).Value 資格.Value = ActiveCell.Offset(0, 4).Value 氏名.Value = ActiveCell.Offset(0, 5).Value カナ.Value = ActiveCell.Offset(0, 6).Value 郵便番号.Value = ActiveCell.Offset(0, 7).Value 住所.Value = ActiveCell.Offset(0, 8).Value 電話番号.Value = ActiveCell.Offset(0, 9).Value コメント.Value = Empty 氏名.SetFocus End With Set Find_1 = Nothing End If End Sub |
| ▼１２３ さん： こんにちは。 >実は、Find.で氏名を検索してExcelシートデータを >ユーザーフォームに表示させていますが、 >同じ名前があると、氏名_Exit では、一番上にあるデータ >に戻ってしまいます。 >解決策はあるでしょうか。 >また、同じ名前があった場合の処理をさせることができるものでしょうか。 >どなたか お助けください。 > >Private Sub 氏名_Exit(ByVal Cancel As MSForms.ReturnBoolean) > >smi = 氏名.Value >If 氏名.Value = "" Then >Exit Sub > >Else > Dim Find_1 As Range > > With ActiveSheet > Set Find_1 = .Range(.Cells(2, 6), .Cells(3000, 6)).Find(smi) > If Find_1 Is Nothing Then > コメント.Value = smi & " は見つかりませんでした。入力し直して下さい。" > 会社名.Value = Empty > 部署.Value = Empty > グループ名.Value = Empty > 役職.Value = Empty > 資格.Value = Empty > 氏名.Value = Empty > カナ.Value = Empty > 郵便番号.Value = Empty > 住所.Value = Empty > 電話番号.Value = Empty > > 氏名.SetFocus > Exit Sub > > End If > > Find_1.Activate > Cells(ActiveCell.Row, 1).Select > 会社名.Value = ActiveCell.Value > 部署.Value = ActiveCell.Offset(0, 1).Value > グループ名.Value = ActiveCell.Offset(0, 2).Value > 役職.Value = ActiveCell.Offset(0, 3).Value > 資格.Value = ActiveCell.Offset(0, 4).Value > 氏名.Value = ActiveCell.Offset(0, 5).Value > カナ.Value = ActiveCell.Offset(0, 6).Value > 郵便番号.Value = ActiveCell.Offset(0, 7).Value > 住所.Value = ActiveCell.Offset(0, 8).Value > 電話番号.Value = ActiveCell.Offset(0, 9).Value > > > コメント.Value = Empty > > 氏名.SetFocus > > End With > > Set Find_1 = Nothing > >End If >End Sub Findnextメソッドを使用すると、同じ名前も取得できますが､ どのタイミングで次の検索をするのですか？ |
| ▼ichinose さん こんにちは。 >Findnextメソッドを使用すると、同じ名前も取得できますが､ >どのタイミングで次の検索をするのですか？ Ａさんを検索し、各TextBoxに情報を入力するのですが、 ＡさんとＢさんが同じ名前の場合、または、Ａさんの情報が重複して いる場合に誤入力を回避したいのです。 そのため、Find.で検索した時点（Aさんの情報が各TextBoxに取得された時点）で、 「他にも同じ名前がありますよ！」ということが分かるようにしたいのです。 また、次のFind.結果を表示させることができれば完璧なのですが．．． いかがでしょうか。 Private Sub 氏名_Exit(ByVal Cancel As MSForms.ReturnBoolean) smi = 氏名.Value If 氏名.Value = "" Then Exit Sub Else Dim Find_1 As Range With ActiveSheet Set Find_1 = .Range(.Cells(2, 6), .Cells(3000, 6)).Find(smi) If Find_1 Is Nothing Then コメント.Value = smi & " は見つかりませんでした。入力し直して下さい。" 会社名.Value = Empty 部署.Value = Empty グループ名.Value = Empty 役職.Value = Empty 資格.Value = Empty 氏名.Value = Empty カナ.Value = Empty 郵便番号.Value = Empty 住所.Value = Empty 電話番号.Value = Empty 氏名.SetFocus Exit Sub End If Find_1.Activate Cells(ActiveCell.Row, 1).Select 会社名.Value = ActiveCell.Value 部署.Value = ActiveCell.Offset(0, 1).Value グループ名.Value = ActiveCell.Offset(0, 2).Value 役職.Value = ActiveCell.Offset(0, 3).Value 資格.Value = ActiveCell.Offset(0, 4).Value 氏名.Value = ActiveCell.Offset(0, 5).Value カナ.Value = ActiveCell.Offset(0, 6).Value 郵便番号.Value = ActiveCell.Offset(0, 7).Value 住所.Value = ActiveCell.Offset(0, 8).Value 電話番号.Value = ActiveCell.Offset(0, 9).Value コメント.Value = Empty 氏名.SetFocus End With Set Find_1 = Nothing End If End Sub |
| ▼１２３ さん： こんにちは。 >Ａさんを検索し、各TextBoxに情報を入力するのですが、 >ＡさんとＢさんが同じ名前の場合、または、Ａさんの情報が重複して >いる場合に誤入力を回避したいのです。 >そのため、Find.で検索した時点（Aさんの情報が各TextBoxに取得された時点）で、 >「他にも同じ名前がありますよ！」ということが分かるようにしたいのです。 >また、次のFind.結果を表示させることができれば完璧なのですが．．． 一応、これで動いていますが・・・、 フォームモジュールに、 '===================================================================== Dim same_rng() As Range '================================================================== Private Sub 氏名_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim Find_1c As Range Dim Find_1 As Range Dim 開始 As Range smi = 氏名.Value If 氏名.Text <> "" Then With ActiveSheet Set 開始 = .Cells(3000, 6) Set Find_1 = find_rng(開始, .Range(.Cells(2, 6), .Cells(3000, 6)), smi) If Find_1 Is Nothing Then コメント.Value = smi & " は見つかりませんでした。入力し直して下さい。" 会社名.Value = Empty 部署.Value = Empty グループ名.Value = Empty 役職.Value = Empty 資格.Value = Empty 氏名.Value = Empty カナ.Value = Empty 郵便番号.Value = Empty 住所.Value = Empty 電話番号.Value = Empty Cancel = True Else Set Find_1c = .Cells(Find_1.Row, 1) Find_1c.Select 'なくても動きますが・・・ 会社名.Value = Find_1c.Value 部署.Value = Find_1c.Offset(0, 1).Value グループ名.Value = Find_1c.Offset(0, 2).Value 役職.Value = Find_1c.Offset(0, 3).Value 資格.Value = Find_1c.Offset(0, 4).Value 氏名.Value = Find_1c.Offset(0, 5).Value カナ.Value = Find_1c.Offset(0, 6).Value 郵便番号.Value = Find_1c.Offset(0, 7).Value 住所.Value = Find_1c.Offset(0, 8).Value 電話番号.Value = Find_1c.Offset(0, 9).Value i = 0 Erase same_rng() Set Find_1 = find_rng(開始) Do Until Find_1 Is Nothing ReDim Preserve same_rng(i) Set same_rng(i) = Find_1 i = i + 1 Set Find_1 = find_rng(開始) Loop コメント.Value = Empty If i >= 1 Then コメント.Value = "他にも同名が" & i & " 人います" mes$ = "" For i = LBound(same_rng()) To UBound(same_rng()) mes$ = mes & same_rng(i).Value & vbLf Next MsgBox mes$ ' とりあえず、重複する氏名を表示するようにしました End If Cancel = True End If End With End If Set Find_1 = Nothing Set Find_1c = Nothing Set 開始 = Nothing End Sub '========================================================================== Function find_rng(開始 As Range, Optional 検索範囲 As Range = Nothing, Optional fwd = "") As Range 'input 検索範囲: 省略可能 検索するセル範囲 ' fwd : 省略可能 検索する文字､数値 'input-output 開始 : 検索開始セルを指定する最初は､最後のセルを指定する ' 2回目以降は、ｻﾌﾞﾙｰﾁﾝがi/oに使用する 'output find_rng :検索した結果条件にあったセル。尚､見つからない場合､もしくは、一通り､検索が終了した場合は､nothingが入る Static sv検索範囲 As Range Static svfwd Static first_fd As Range Dim fd As Range If Not 検索範囲 Is Nothing Then Set sv検索範囲 = 検索範囲 svfwd = fwd Set first_fd = Nothing End If With sv検索範囲 If first_fd Is Nothing Then Set fd = .Find(svfwd, 開始, LookIn:=xlValues) Set first_fd = fd Set 開始 = fd Set find_rng = fd Else Set fd = .FindNext(開始) If Not Intersect(first_fd, fd) Is Nothing Then Set find_rng = Nothing Else Set 開始 = fd Set find_rng = fd End If End If End With End Function 以上です。excel2000。 |
| ▼ichinose さん ありがとうございます。 しかし、あまりに高度で、なかなか理解できないところ があります。 少し時間が必要です。とりあえず、丸写しでやってみます。 また、後程 |
| ▼ichinose さん： できました。 理解は出来ていないけど、丸写しでできました。 ありがとうございます。 ずうずうしいのですが、 見つかった同じ名前のデータを各TextBoxに呼び込むには どうしたらよいのでしょうか。 複数のデータを一旦どこかに収納しなければいけないような気がしますが．．． また、同じことなのですが、例えば「山田*」を入力すると、 山田さんが5人見つかります。この中の「山田太郎」さんを選んで 各TextBoxにデータを表示させたいのですが、 可能でしょうか。 今の私の知識を遥かに超えています。 どうぞお助けください。 |
| ▼１２３ さん： >見つかった同じ名前のデータを各TextBoxに呼び込むには >どうしたらよいのでしょうか。 >複数のデータを一旦どこかに収納しなければいけないような気がしますが．．． >また、同じことなのですが、例えば「山田*」を入力すると、 >山田さんが5人見つかります。この中の「山田太郎」さんを選んで >各TextBoxにデータを表示させたいのですが、 フォームにリストボックスを追加してください（オブジェクト名は、既定のListBox1）。 １２３ さんの例ですと､見つかった５人の山田さんの名前がリストボックスに表示されます（重複する場合のみ表示し､一人の場合は､リストボックスには表示しません）。 最初の山田さんのデータがテキストボックスに表示されます。リストボックスでも対応する山田さんが選択されています。 このリストボックスの選択を変えると、テキストボックスのそれぞれの情報も対応して変わる、ということにしました。 '=================================================================== Dim ev_sw As Integer '0:リストボックスのイベントを実行 '1:リストボックスのイベントを実行しない Dim same_rng() As Range '条件に合った氏名の入ったセル '=================================================================== Private Sub ListBox1_Change() If ev_sw <> 1 Then With ListBox1 Call テキストボックスへの表示(same_rng(.ListIndex)) End With End If End Sub '=================================================================== Private Sub 氏名_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim Find_1 As Range Dim 開始 As Range Call clear_listbox1 Erase same_rng() smi = 氏名.Value If 氏名.Text <> "" Then With ActiveSheet Set 開始 = .Cells(3000, 6) Set Find_1 = find_rng(開始, .Range(.Cells(2, 6), .Cells(3000, 6)), smi) If Find_1 Is Nothing Then コメント.Value = smi & " は見つかりませんでした。入力し直して下さい。" 会社名.Value = Empty 部署.Value = Empty グループ名.Value = Empty 役職.Value = Empty 資格.Value = Empty 氏名.Value = Empty カナ.Value = Empty 郵便番号.Value = Empty 住所.Value = Empty 電話番号.Value = Empty Cancel = True Else Call テキストボックスへの表示(Find_1) i = 0 ReDim Preserve same_rng(i) Set same_rng(i) = Find_1 i = 1 Set Find_1 = find_rng(開始) Do Until Find_1 Is Nothing ReDim Preserve same_rng(i) Set same_rng(i) = Find_1 i = i + 1 Set Find_1 = find_rng(開始) Loop コメント.Value = Empty If i > 1 Then コメント.Value = "他にも同名が" & i & " 人います" Call set_listbox1 End If End If End With Else Cancel = True End If Set Find_1 = Nothing Set 開始 = Nothing End Sub '===================================================================== Function find_rng(開始 As Range, Optional 検索範囲 As Range = Nothing, Optional fwd = "") As Range 'input 検索範囲: 省略可能 検索するセル範囲 ' fwd : 省略可能 検索する文字､数値 'input-output 開始 : 検索開始セルを指定する最初は､最後のセルを指定する ' 2回目以降は、ｻﾌﾞﾙｰﾁﾝがi/oに使用する 'output find_rng :検索した結果条件にあったセル。尚､見つからない場合､もしくは、一通り､検索が終了した場合は､nothingが入る Static sv検索範囲 As Range Static svfwd Static first_fd As Range Dim fd As Range If Not 検索範囲 Is Nothing Then Set sv検索範囲 = 検索範囲 svfwd = fwd Set first_fd = Nothing End If With sv検索範囲 If first_fd Is Nothing Then Set fd = .Find(svfwd, 開始, LookIn:=xlValues) Set first_fd = fd Set 開始 = fd Set find_rng = fd Else Set fd = .FindNext(開始) If Not Intersect(first_fd, fd) Is Nothing Then Set find_rng = Nothing Else Set 開始 = fd Set find_rng = fd End If End If End With End Function '===================================================================== Sub テキストボックスへの表示(rng As Range) Dim find_1c As Range Set find_1c = ActiveSheet.Cells(rng.Row, 1) 会社名.Value = find_1c.Value 部署.Value = find_1c.Offset(0, 1).Value グループ名.Value = find_1c.Offset(0, 2).Value 役職.Value = find_1c.Offset(0, 3).Value 資格.Value = find_1c.Offset(0, 4).Value 氏名.Value = find_1c.Offset(0, 5).Value カナ.Value = find_1c.Offset(0, 6).Value 郵便番号.Value = find_1c.Offset(0, 7).Value 住所.Value = find_1c.Offset(0, 8).Value 電話番号.Value = find_1c.Offset(0, 9).Value End Sub '===================================================================== Sub set_listbox1() Dim idx As Long ev_sw = 1 With ListBox1 for idx = LBound(same_rng()) To UBound(same_rng()) .AddItem same_rng(idx).Value, idx Next idx .ListIndex = 0 End With ev_sw = 0 End Sub '====================================================================== Sub clear_listbox1() ev_sw = 1 With ListBox1 .Clear End With ev_sw = 0 End Sub 簡単にテストでは動いています。 |
| ▼ichinose さん： 凄すぎです。 感激しています。 本当にありがとうございました。 実は．．． リストボックスで選んだ名前の行の最左端セルを アクティブにしたいのです。 アクティブな最左端セルからのOffsetで、データを 入力（更新）しています。 何度もすみません。 |
| ▼１２３ さん： こんにちは。 >リストボックスで選んだ名前の行の最左端セルを >アクティブにしたいのです。 >アクティブな最左端セルからのOffsetで、データを >入力（更新）しています。 >何度もすみません。 いいえ、私の勉強にもなりますから・・。 '============================================================== >Sub テキストボックスへの表示(rng As Range) > Dim find_1c As Range > Set find_1c = ActiveSheet.Cells(rng.Row, 1) find_1c.Activate > 会社名.Value = find_1c.Value > 部署.Value = find_1c.Offset(0, 1).Value > グループ名.Value = find_1c.Offset(0, 2).Value > 役職.Value = find_1c.Offset(0, 3).Value > 資格.Value = find_1c.Offset(0, 4).Value > 氏名.Value = find_1c.Offset(0, 5).Value > カナ.Value = find_1c.Offset(0, 6).Value > 郵便番号.Value = find_1c.Offset(0, 7).Value > 住所.Value = find_1c.Offset(0, 8).Value > 電話番号.Value = find_1c.Offset(0, 9).Value >End Sub でいいと思いますが､ブロシジャー名は機能が追加されてますから変えたほうがいいかもしれません。 |
| ▼ichinose さん： こんにちは。 たびたびすみませんでした。 題名通り、あまりにも完璧すぎです。 私の期待通りのもの そのものです。 ありがとうございました。 ところで、このひとつ前の段階から、 ファイルを終了させるとエラーメッセージがでるようになりました。 「エラーが発生したため、EXCEL.exeを終了します。プログラムをもう一度開始する必要があります。エラーログを作成しています。」 というメッセージですが、「OK」をクリックすると終わります。 他のVBAのファイルでは問題ないのですが、お世話になっているファイルだけが 出てしまいます。 もし原因がおわかりでしたら、教えてくださいませんでしょうか。 （作業中は全く問題なく動作します） |
| ▼ichinose さん： こんにちは。 私の同僚であるハンドルネーム「会社員さん」の ＰＣで返事を書いてしまいましたので、 投稿者の部分を書き換えるのを忘れてしまいました。 私は１２３です。 お礼は私１２３が書きました。 それとエラーメッセージについてですが、 もう メッセージが出なくなりました。 お騒がせいたしました。 >ところで、このひとつ前の段階から、 >ファイルを終了させるとエラーメッセージがでるようになりました。 >「エラーが発生したため、EXCEL.exeを終了します。プログラムをもう一度開始する必要があります。エラーログを作成しています。」 >というメッセージですが、「OK」をクリックすると終わります。 >他のVBAのファイルでは問題ないのですが、お世話になっているファイルだけが >出てしまいます。 >もし原因がおわかりでしたら、教えてくださいませんでしょうか。 >（作業中は全く問題なく動作します） |