[[20150124145945]] 『シートから検索された結果を、ユーザーフォームに』(タケダユミ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『シートから検索された結果を、ユーザーフォームに表示し、変更点・追記をした後、シートの元データに上書きする』(タケダユミ)

現在作成してあるのは、
○データ入力用のユーザーフォーム1
  新規データ・データ変更のコマンドボタンあり
○データの入力されるシート
○シートから検索するためのユーザーフォーム2
  検索ワード用テキストボックス・検索用コマンドボタン・表示用リストボックスあり

です。

UF1でデータを入力し新規データボタンを押すと、シートの最下段に入力します。
UF2内のテキストボックスに検索ワードを入れ、検索ボタンを押すと、リストボックスに該当データが表示されます。
リストボックスに表示された検索結果のひとつををクリックすると、シートのデータがUF1に表示されます。
ここまでは何とか作成できています。

検索結果から転記されたUF1のデータに変更を加えて、データ変更ボタンを押したときに、シートのデータが上書きされるようにしたいのですが、どのような方法をとったら良いか分からずにいます。

どなたかお力を貸して頂けないでしょうか?

< 使用 Excel:Excel2013、使用 OS:Windows7 >


http://www.moug.net/faq/viewtopic.php?t=71168

 これと、テーマが似ていますが、同じ人?
 それはさておき、現在、どうにかできているコードをアップすれば、具体的なアドバイスが寄せられると思いますよ。

(β) 2015/01/24(土) 15:32


 アップされるコード次第ですけど、先走りでメモ的に。

 17:26 追記 以下のメモは UF1,UF2 がともに表示されているという前提です。
       どちらか一方のみが表示される形であれば、少し手順がかわります。

 ・まず、この処理はユーザーフォームを分けずに同じユーザーフォーム内で実行したほうが
  コードが容易になることもありますが、柔軟さがまし、将来の追加変更時にも有益だと思います。
 ・とはいえ、すでに存在するUF2のロジックを移植するのも大変だ、また UF2には本件以外に
  独自の機能ももっている ということかもしれませんので、UF1,UF2 二本立てで考えるとして。
 ・課題は、UF2で選ばれていないのに、UF1で更新ボタンが押されたとき、データを、どの行に対して
  セットしたらいいかわからない、いいかえれば、そういったときは、更新ボタンが押されても
  処理したらいけないという制御をすることが必要ということです。
 ・いろんな方法がありますが、わりと簡単なのは

  1)更新ボタンの制御
    デザイン時には、Enabled を False あるいは Visible をFalse に設定しておく。
    UF2側でListBoxから選択された時点で、現在やっていると思われる、UF1へのデータ受渡とともに
    UF1.更新ボタン.Enabled あるいは UF1.更新ボタン.Visible を True にする。
    UF1側で更新実行されたら、UF1側で、このボタンの EnabledあるいはVisibeをFalseにする。
  2)データの行情報の取得
    現在、UF2側でなんらかの抽出条件処理で該当のものをListBoxのリストに設定していると思われますが
    このListBoxの表示される列数の+1の列に抽出したシートの行番号も格納しておきます。(表示はされない)
    UF2側に、Public 選択row As Long を モジュールレベルで規定しておいて、ListBox のクリックイベントで
    この選択Row に 選ばれたリストの行の、隠れている列の行番号をセットします。
    で、UF1側で更新ボタンが押されたとき、 UF2.選択Row から、書き込むべきシートの行番号を取得します。

(β) 2015/01/24(土) 16:19


βさま(で宜しいでしょうか)

早速のご回答ありがとうございます!
リンク先の方とは別人です。
でも、そちらも参考にした方が勉強になりそうですね!
ありがとうございます!

コードを貼り付けようと思います!
しかし、ご指摘頂いたときには、退社しておりました。
アドバイス頂きながら、レスが遅くて申し訳ありませんが、今しばらくコードお待ち頂けますでしょうか。
段取りが悪くて申し訳ありません。

よろしくお願い致します。
(タケダユミ) 2015/01/24(土) 17:44


遅くなり申し訳ありません。
今できているコードを書かせて頂きます。

●データ入力用のUF1にある、シートにデータを入力するための入力用コマンドボタンに書いたコードは、実際にはもっと項目が多いですが以下のような感じです。
:::::::::::::
Private Sub CommandButton1_Click() 'データ入力ボタン

  Range("C65536").End(xlUp).Offset(1, -1).Select   '←データのC列のデータを見ている。最終データの後に入力する。

  With ActiveCell
    .Offset(0, 0) = TextBox80.Text   
    .Offset(0, 1) = TextBox81.Text    
    .Offset(0, 2) = TextBox82.Text    
    .Offset(0, 4) = ComboBox31.Text
    .Offset(0, 5) = TextBox84.Text 

  End With

 Unload UserForm1

End Sub

:::::::::::::::

●検索用UF2に作った、検索コマンドボタンには、以下のようなコードを書いています。
TextBox1に入れたワードを検索し、ListBox1に表示しています。
::::::::::::::::
Private Sub CommandButton1_Click()

Dim r As Range, FirstCell As Range, rng As Range
Dim vnt As Variant
Dim prow As Long
Dim s As Worksheet
Dim cnt As Long

    Set s = Sheets("データベース")
    Set rng = Intersect(s.Range("B:B"), s.UsedRange)
    Set r = rng.Find(What:=TextBox1.Text)

    If r Is Nothing Then
      MsgBox "該当するデータが見つかりません"
      GoTo Exit_sub
    End If

    Set FirstCell = r
    ReDim vnt(0)
    vnt(0) = s.Cells(r.Row, 1).Resize(1, 102).Value
    prow = r.Row
    cnt = 1
    Do
        Set r = rng.FindNext(r)
        If Not r Is Nothing And (r.Address <> FirstCell.Address) _
                And (FirstCell.Row <> r.Row) And (prow <> r.Row) Then
            ReDim Preserve vnt(UBound(vnt) + 1)
            vnt(UBound(vnt)) = s.Cells(r.Row, 1).Resize(1, 102).Value
            prow = r.Row
            cnt = cnt + 1
        End If
    Loop While r.Address <> FirstCell.Address

    If cnt = 1 Then vnt = s.Cells(FirstCell.Row, 1).Resize(1, 102).Value
    If cnt > 1 Then vnt = Application.Transpose(Application.Transpose(vnt))
    ListBox1.List = vnt

    Set FirstCell = Nothing
    Erase vnt
 Exit_sub:
    Set r = Nothing
    Set rng = Nothing
    Set s = Nothing

End Sub

:::::::::::::::::

●リストボックスに検索された結果をクリックすると、UF1にデータが表示されるようにしたコードは以下のような感じです。

:::::::::::::::::
Private Sub ListBox1_Change()

 With Me.ListBox1

 UserForm1.TextBox80.Text = .List(.ListIndex, 1)
 UserForm1.TextBox81.Text = .List(.ListIndex, 2)
 UserForm1.TextBox82.Text = .List(.ListIndex, 3)

  UserForm1.Show

 End With

End Sub
::::::::::::::::::
(タケダユミ) 2015/01/27(火) 14:24


 コードアップありがとうございます。
 ちょっとサンプルを書いてみます。

(β) 2015/01/27(火) 14:34


 遅くなりました。個人的には、UF1とUF2をともに横並びに表示して、UF2側で終了時にUF1もUNLOADしてはとも思いますが
 しっかりしたコードで組み立てられていますので、現行の構成で最小限の追加修正にしました。
 なお、UserForm1側の更新ボタンを、仮に CommandButton2 にしてあります。
 また、UF2からUF1への選択行番号の受け渡しは UserForm1のTagを使っています。

 ところで、お使いの Find ですが、What:のみの指定になっていますね。そのほかの重要な引数、特に LookIn や LookAt は
 指定がなければ、直前の、マクロによる FindやReplace、エクセル操作による置換や検索での指定を引き継ぎます。
 たとえば、このマクロを実行する前に、このPCで、部分一致の検索を行っていれば、このマクロのFindは部分一致になりますし
 完全一致の置換を行っていれば、このマクロのFindは完全一致になります。
 ですから、これらも、きちんと明示的に指定しておくべきですね。

 UserForm2 モジュール 

 Private Sub CommandButton1_Click()

    Dim r As Range, FirstCell As Range, rng As Range
    Dim vnt As Variant
    Dim prow As Long
    Dim s As Worksheet
    Dim cnt As Long
    Dim w As Variant        '★追加

    Set s = Sheets("データベース")
    Set rng = Intersect(s.Range("B:B"), s.UsedRange)
    Set r = rng.Find(What:=TextBox1.Text)

    If r Is Nothing Then
        MsgBox "該当するデータが見つかりません"
        GoTo Exit_sub
    End If

    Set FirstCell = r
    ReDim vnt(0)
    w = s.Cells(r.Row, 1).Resize(1, 103).Value  '★追加
    w(1, 103) = r.Row                           '★追加
    vnt(0) = w                                  '★修正

    prow = r.Row
    cnt = 1

    Do
        Set r = rng.FindNext(r)
        If Not r Is Nothing And (r.Address <> FirstCell.Address) _
            And (FirstCell.Row <> r.Row) And (prow <> r.Row) Then
            ReDim Preserve vnt(UBound(vnt) + 1)
            w = s.Cells(r.Row, 1).Resize(1, 103).Value  '★追加
            w(1, 103) = r.Row                           '★追加
            vnt(UBound(vnt)) = w                        '★修正
            prow = r.Row
            cnt = cnt + 1
        End If
    Loop While r.Address <> FirstCell.Address
    If cnt = 1 Then vnt = w                     '★修正
    If cnt > 1 Then vnt = Application.Transpose(Application.Transpose(vnt))
    ListBox1.List = vnt

    Set FirstCell = Nothing
    Erase vnt

 Exit_sub:
    Set r = Nothing
    Set rng = Nothing
    Set s = Nothing

 End Sub

 Private Sub ListBox1_Change()

    With Me.ListBox1

        Userform1.TextBox80.Text = .List(.ListIndex, 1)
        Userform1.TextBox81.Text = .List(.ListIndex, 2)
        Userform1.TextBox82.Text = .List(.ListIndex, 3)
        Userform1.Tag = .List(.ListIndex, 102)          '★追加
        Userform1.Show

    End With

 End Sub

 UserForm1 モジュール

  Private Sub CommandButton1_Click() 'データ入力ボタン
    Dim i As Long
    'C列のデータ最終行の次の行の B列〜F列にデータをセット
    i = Range("C" & Rows.Count).End(xlUp).Offset(1).Row
    UpDate i

 End Sub

 Private Sub CommandButton2_Click()
    'UserForm2のListBox1で選ばれた行を更新
    UpDate CLng(Me.Tag)
 End Sub

 Private Sub UpDate(i As Long)

    With Rows(i)
        .Range("B1").Value = TextBox80.Text
        .Range("C1").Value = TextBox81.Text
        .Range("D1").Value = TextBox82.Text
        .Range("E1").Value = ComboBox31.Text
        .Range("F1").Value = TextBox84.Text
    End With

    Unload Me

 End Sub

(β) 2015/01/27(火) 17:31


 ところで、もし、データベースシートの1行目がタイトル行なら、UF2のCommandButton1クリックルーティンは
 Findのループなしで以下のよう書くこともできます。 ご参考まで。
 なお、作業シートとして Sheet2(非表示でもOKです)、また データベースシートのCY列を作業列に使います。

 Private Sub CommandButton1_Click()

    Dim s As Worksheet

    Set s = Sheets("データベース")
    s.Range("Cy1").Value = 0
    s.Range("CY1").Resize(s.Range("A1").CurrentRegion.Rows.Count).DataSeries Rowcol:=xlColumns
    With Sheets("Sheet2")
        .UsedRange.Clear
        s.Range("A1").CurrentRegion.Rows(1).Copy .Range("A1")
        .Range("DA1").Value = .Range("B1").Value
        .Range("DA2").Value = TextBox1.Text
        s.Range("A1").CurrentRegion.Columns("A:CY").AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("A1:CY1"), CriteriaRange:=.Range("DA1:DA2"), Unique:=False
        If .Range("A1").CurrentRegion.Rows.Count = 1 Then
            MsgBox "該当するデータが見つかりません"
        Else
            With .Range("A1").CurrentRegion
                ListBox1.List = Intersect(.Cells, .Cells.Offset(1)).Value
            End With
        End If
        .UsedRange.Clear
        s.Columns("CY").Clear
    End With

 End Sub

(β) 2015/01/28(水) 06:51


 上でレスした通り、部分一致が必要なのか完全一致が必要なのかがわからなかったので
 2015/01/28(水) 06:51 にアップしたコードは部分一致で抜き出すようにしてあります。
 もし、完全一致がお望みなら

 .Range("DA2").Value = TextBox1.Text

 これを

 .Range("DA2").Value = "=""=" & TextBox1.Text & """"

 このように変更してください。

(β) 2015/01/28(水) 09:48


βさま

早速、手直しして頂きありがとうございます!
指摘していただいた点、じっくり勉強したいと思います。

無事、理想的な作動をしてくれました!

『完全一致』『部分一致』の件も、今後の用途を考慮しながら検討したいと思います。

取り急ぎ、お礼を伝えたくコメントしました!

完成までもう少し時間が必要ですが、また困った際にお力を貸して頂けると助かります!

ありがとうございました。
(タケダユミ) 2015/01/28(水) 16:56


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.