Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9224 / 13644 ツリー ←次へ | 前へ→

【28486】検索該当行の複数セル値の取得について BON8021 05/9/7(水) 19:56 質問[未読]
【28487】Re:検索該当行の複数セル値の取得について ponpon 05/9/7(水) 21:25 発言[未読]
【28525】Re:検索該当行の複数セル値の取得について BON8021 05/9/8(木) 16:19 質問[未読]
【28540】Re:検索該当行の複数セル値の取得について ponpon 05/9/8(木) 21:22 発言[未読]
【28611】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 10:29 質問[未読]
【28615】Re:検索該当行の複数セル値の取得について ponpon 05/9/10(土) 11:27 発言[未読]
【28619】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 12:10 質問[未読]
【28636】Re:検索該当行の複数セル値の取得について ponpon 05/9/10(土) 21:40 発言[未読]
【28498】Re:検索該当行の複数セル値の取得について kobasan 05/9/8(木) 7:52 回答[未読]
【28609】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 9:44 質問[未読]
【28612】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 10:30 回答[未読]
【28613】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 10:36 回答[未読]
【28616】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 11:31 質問[未読]
【28623】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 14:16 回答[未読]
【28627】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 15:15 質問[未読]
【28628】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 15:35 回答[未読]
【28630】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 16:21 お礼[未読]
【28614】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 10:40 回答[未読]
【28617】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 12:05 質問[未読]
【28622】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 14:02 回答[未読]
【28624】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 14:48 お礼[未読]
【28631】Re:検索該当行の複数セル値の取得について BON8021 05/9/10(土) 17:16 質問[未読]
【28632】Re:検索該当行の複数セル値の取得について kobasan 05/9/10(土) 19:35 回答[未読]

【28486】検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/7(水) 19:56 -

引用なし
パスワード
   標記の件について、教えて下さい。

あるシートにマスタを管理していて、その他のシートからマスタを
検索し、該当した値を取得したいと思っています。
その際、検索キーが複数あり、その検索キーに該当した行の
指定した列を複数取得したいと思っています。

例)
マスタシートは、以下の通り。
1列目 ・・・・ k列目 ・・・・ m列目 ・・・・ n列目 
wwww     aaaa     1111     2222
xxxx     aaaa     3333     4444
yyyy
zzzz

あるシートのセルに1列目の値”wwww”とk列目の値”aaaa”を
指定すると、マスタシートの検索を行い、該当行のm列目の値”1111”と
n列目の値”2222”を取得してセットしたいです。
また、マスタに該当行が複数あるのは、ご法度ですが、こちらについては、
該当行が複数あれば、警告メッセージ等で表示したいと思っています。
どなたか、お知恵を拝借できないでしょうか。

【28487】Re:検索該当行の複数セル値の取得について
発言  ponpon  - 05/9/7(水) 21:25 -

引用なし
パスワード
   こんばんは。

>あるシートのセルに1列目の値”wwww”とk列目の値”aaaa”を
>指定する

これは、どこ指定するのでしょうか?
あるシートのA列とK列の1行目ですか?2行目ですか?

マスタシートの
1列目には、重複は、ないのでしょうか?

なければ、Application.Matchで
あれば、Find、FindNextで
検索されたらいかがでしょうか?

あとは、オフセットしたセルの値と指定した値が同じかどうかを比較すれば
よいかと。

もう少し詳しく、仕様を説明すると、レスがつきやすいと思います

【28498】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/8(木) 7:52 -

引用なし
パスワード
   おはようございます。

スマートでないですが、参考までに。

Sheet1が転記用シートです。
Sheet2がマスターです。


Sheet1のモジュールに貼り付けてください。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rng2 As Range, r As Range
Dim EndC2 As Range
Dim r1 As Range, r2 As Range
Dim 行 As Long
Dim i As Long
Dim flag As String


  If Target.Count > 1 Then Exit Sub
  If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
  行 = Target.Row
  If Cells(行, "A").Value = "" Then del 行: Exit Sub
  If Cells(行, "K").Value = "" Then del 行: Exit Sub
  '
  Set EndC2 = Sheets("Sheet2").Range("A65536").End(xlUp)
  Set rng2 = Sheets("Sheet2").Range("A2", EndC2) 'データ範囲(参照元)
  '
  flag = ""
  For Each r In Range("A2", Range("A65536").End(xlUp))
    If r.Row <> 行 Then
      If Cells(行, "A").Value & Cells(行, "K").Value = _
        Cells(r.Row, "A").Value & Cells(r.Row, "K").Value Then
        Beep
        MsgBox "重複"
        Exit For
      End If
    End If
  Next
  '
  Application.EnableEvents = False
  For Each r2 In rng2
    If r2.Value & r2.Offset(, 10).Value = _
      Cells(行, "A").Value & Cells(行, "K").Value Then
     
      Cells(行, "M").Value = r2.Offset(, 12)
      Cells(行, "N").Value = r2.Offset(, 13)
      GoTo jump
    End If
  Next
  del 行
jump:
  Application.EnableEvents = True
  Set dic = Nothing
  Set EndC2 = Nothing
  Set rng2 = Nothing
  Set r1 = Nothing
  Set r2 = Nothing
End Sub

Private Sub del(r As Long)
Range(Cells(r, "m"), Cells(r, "n")).ClearContents
End Sub

【28525】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/8(木) 16:19 -

引用なし
パスワード
   ▼ponpon さん:
回答ありがとうございます。

>あるシートのセルに1列目の値”wwww”とk列目の値”aaaa”を
>指定する
>
>これは、どこ指定するのでしょうか?
>あるシートのA列とK列の1行目ですか?2行目ですか?

実は、現在、代価表なるものを作成しております。
代価表とは、土木・建築の作業基準金額一覧(工種一覧)みたいなものであり、
国交省の年1回の工種金額改定(単価の見直し)により、毎年、更新させる必要が
あります。
マスタシートとは、単価マスタのことであり、1列に品名(部材名 or 作業名)、
k列目に規格、m列目に寸法、n列目に単価があります。
一方、あるシートとは、代価表シートそのものであり、ある作業をする際に
必要となる品名を1グループで見積り、ある作業は、いくらという基準を
出すものです。
よって、土木・建築工事があった場合、この作業(代価表1)とあの作業(代価表2)
の組合せで作業を行うという形で、積算(集計)していきます。
今回、代価表のしくみが完成すると、国交省の影響で変更せざるをえない単価
のみを変更すると、その都度(時期)の積算書(見積書)ができるようになります。

ですから、あるシートには、1行目の1列目に品名、1行目の2列目に規格を
指定すると、1行目の3列目に寸法、5列目に単価が取得できればと思います。
1行目の4列目には、数量を入力し、1行目の6列目に価格(4列目と5列目の掛け算)
を表示する予定です。
2行目以降は、1行目以降の繰り返しで、都合、20行目までを繰り返します。
21行目には、合計金額を表示します。

ここで、検索に使用したい項目は、1列目の品名と2列目の規格になり、
この2項目に該当した行を単価マスタより見つけ、値をセットしたいです。
単価マスタは、1列目の品名、k列目の規格でユニークとなります。
※ユニークと書いてあるので、単価マスタに入力する際は、気をつけたいと
思いますが、重複があった場合は、代価表での検索時に警告メッセージを
表示したいと思っています。

>マスタシートの
>1列目には、重複は、ないのでしょうか?
上記の説明により、重複はあります。

>なければ、Application.Matchで
>あれば、Find、FindNextで
>検索されたらいかがでしょうか?

>あとは、オフセットしたセルの値と指定した値が同じかどうかを比較すれば
>よいかと。

>もう少し詳しく、仕様を説明すると、レスがつきやすいと思います
ご忠告ありがとうございます。つたない説明ですみませんが、どなたか、
解決手法を教えてください。

【28540】Re:検索該当行の複数セル値の取得について
発言  ponpon  - 05/9/8(木) 21:22 -

引用なし
パスワード
   こんばんは。

こんなもんでいかがでしょう?
標準モジュールにコピペしてください。
シートの名前はそちらに合わせてください。

※品名と規格に重複がある場合は、一つ目は、そのまま転記
 二つ目に、重複した値とアドレスを出すようにしています。


Sub test()
   Dim SH1 As Worksheet, SH2 As Worksheet
   Dim myR As Range, myR2 As Range
   Dim r As Range, c As Range
  
   Set SH1 = Worksheets("単価マスタ")
   Set SH2 = Worksheets("代価表シート")
   Set myR = SH1.Range("A2", SH1.Range("A65536").End(xlUp))
   Set myR2 = SH2.Range("A2", SH2.Range("A65536").End(xlUp))
  
   For Each r In myR2
    t = 0
    For Each c In myR
     If r.Value = c.Value Then
      If c.Offset(0, 10).Value = r.Offset(0, 1).Value Then
       t = t + 1
       If t > 1 Then
        MsgBox "規格" & c.Offset(0, 10).Value & _
            "(" & c.Offset(0, 10).Address(0, 0) & ")" & _
            vbCrLf & "が重複しています"
               
        Exit For
       End If
       r.Offset(0, 2).Value = c.Offset(0, 12).Value
       r.Offset(0, 4).Value = c.Offset(0, 13).Value
      End If
     End If
    Next
   Next

End Sub

【28609】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 9:44 -

引用なし
パスワード
   ▼kobasan さん:

回答ありがとうございます。
現在、チャレンジ中ですが、なかなかうまくいきません。

if文でTRUE判定された後、マッチングした値を代入するところまでは、
良いのですが、その後、無限ループに入ったような動きをします。

その文をコメント行にすると、正常終了します。

いまいち、Rangeという型をよく理解できていないところから
始まっているのかもしれません。

そもそも、Rangeという型宣言された変数には、何が入るのでしょうか。
Rangeという型について、少々、教えて頂くと助かります。

【28611】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 10:29 -

引用なし
パスワード
   ▼ponpon さん:

回答ありがとうございます。
ご教示頂いた内容にて、チャレンジしてみました。
しかしながら、正常に動作しません。

デバックモードで観察すると、For文の中でのIF文の判定条件までは
良いのですが、TRUEの際に処理される行の中で、値が設定された後、
無限ループに陥ってしまいます。

値(右辺側)については、デバックモード及び画面に表示して、確認している
ので間違いないと思います。
(ちなみに、この部分までで、該当行を正確に検索できるようになりました。
 ありがとうございます。)

IF文内で、値をセットする行をコメント行にすると正常終了します。

>r.Offset(0, 2).Value = c.Offset(0, 12).Value

上記、値の設定する行で注意すべき点があれば教えてください。

私の中では、rという変数の型であるRange型の特徴がいまいち、理解できて
いない気がします。
それとも、値を設定する際、なにかをアクティブにしなければ、セット
できない等があるんでしょうか。

初歩的な質問をして、誠に申し訳ないのですが、教えてください。

【28612】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 10:30 -

引用なし
パスワード
   ▼BON8021 さん ponponさん おはようございます。

>いまいち、Rangeという型をよく理解できていないところから
>始まっているのかもしれません。

>そもそも、Rangeという型宣言された変数には、何が入るのでしょうか。
>Rangeという型について、少々、教えて頂くと助かります。

Rangeで変数宣言すると、その変数に対してプロパティやメソッドを使用することができます。
つまり
Dim r as Range,r1 as Range,r2 as Range
とすると、
Range プロパティ
Range("A5").Value
Range("A5").Activate
Range("A5").ClearContents
Union(range1, range2)

のように

r.Value
r.Activate
r.ClearContents
Union(r1, r2)

のようにつかえます。

比較のために、
Dim I as integer
Dim r as Range
    I=r.value
とすると、
    I.Value
という使い方はできません。


ヘルプでRangeを検索すると説明が出てきます。
以下その一部です。

Range オブジェクト               
セル、行、列、1 つ以上のセル範囲を含む選択範囲、または 3-D 範囲を表します。

使い方
Range オブジェクトを取得するプロパティ、およびメソッドを次に示します。

Range プロパティ
Range("A5").Value = _
Range("A5").Activate
Range("A5").ClearContents

Union メソッド
複数のセル範囲の集合を取得するには、
Union(range1, range2, ...)
Unionメソッド使用します。

>if文でTRUE判定された後、マッチングした値を代入するところまでは、
>良いのですが、その後、無限ループに入ったような動きをします。

>その文をコメント行にすると、正常終了します。

どのぶぶんか。そのコードを載せてもらうと、考えやすいのですが。

それから、改良したコードとdictionaryを利用したコードの2種類を別スレッドにアップしますので参考にしてください。

【28613】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 10:36 -

引用なし
パスワード
   改良版です。
整理と追加をしてみました。
マスターの重複もチェックしています。

Sheet1が転記用シートです。
Sheet2がマスターです。

=====================================================
Sheet1モジュールに

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim EndC2 As Range, rng2 As Range
Dim r As Range
Dim 行 As Long
  '
  行 = Target.Row
  If Target.Count > 1 Then Exit Sub
  If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
  If Cells(行, "A").Value = "" Then del 行: Exit Sub
  If Cells(行, "K").Value = "" Then del 行: Exit Sub
  '
  Set EndC2 = Sheets("Sheet2").Range("A65536").End(xlUp)
  Set rng2 = Sheets("Sheet2").Range("A2", EndC2) 'データ範囲(参照元)
  '
  For Each r In Range("A2", Range("A65536").End(xlUp))
    If r.Row <> 行 Then
      If Cells(行, "A").Value & Cells(行, "K").Value = _
        Cells(r.Row, "A").Value & Cells(r.Row, "K").Value Then
        Beep
        MsgBox "重複"
        del 行
        Target.ClearContents
        Target.Select
        GoTo Jump
      End If
    End If
  Next
  '
  del 行
  Application.EnableEvents = False
  For Each r In rng2
    If r.Value & r.Offset(, 10).Value = _
      Cells(行, "A").Value & Cells(行, "K").Value Then
      Cells(行, "M").Resize(, 2).Value = r.Offset(, 12).Resize(, 2).Value
      Exit For
    End If
  Next
  Application.EnableEvents = True
  '
Jump:
  Set rng2 = Nothing
  Set EndC2 = Nothing
End Sub

Private Sub del(r As Long)
  Range(Cells(r, "m"), Cells(r, "n")).ClearContents
End Sub


===========================================================

Sheet2モジュールに

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim 行 As Long

  行 = Target.Row
  If Target.Count > 1 Then Exit Sub
  If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
  If Cells(行, "A").Value = "" Then Exit Sub
  If Cells(行, "K").Value = "" Then Exit Sub
  '
  For Each r In Range("A2", Range("A65536").End(xlUp))
    If r.Row <> 行 Then
      If Cells(行, "A").Value & Cells(行, "K").Value = _
        Cells(r.Row, "A").Value & Cells(r.Row, "K").Value Then
        Beep
        MsgBox "重複"
        Target.ClearContents
        Target.Select
        Exit For
      End If
    End If
  Next

End Sub

【28614】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 10:40 -

引用なし
パスワード
   Dictionary版です。

マスターの重複もチェックしています。

Sheet1が転記用シートです。
Sheet2がマスターです。

=====================================================
Sheet1モジュールに

Option Explicit

Private dicM As Object

Private Sub Worksheet_Deactivate()
  Set dicM = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dic1 As Object
Dim 行 As Long
Dim vntA, vntK
Dim i As Long, LastR As Long, mr As Long

  行 = Target.Row
  If Target.Count > 1 Then Exit Sub
  If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
  If Cells(行, "A").Value = "" Then del 行: Exit Sub
  If Cells(行, "K").Value = "" Then del 行: Exit Sub
  '
  If dicM Is Nothing Then make_dicM
  LastR = Range("A65536").End(xlUp).Row
  Set dic1 = CreateObject("Scripting.Dictionary")
  vntA = Range("A2", Range("A" & LastR)).Value
  vntK = Range("K2", Range("K" & LastR)).Value
  For i = 1 To UBound(vntA)
    If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
      dic1(vntA(i, 1) & vntK(i, 1)) = dic1(vntA(i, 1) & vntK(i, 1)) + 1
    End If
  Next
  '
  If dic1(Cells(行, "A").Value & Cells(行, "K").Value) > 1 Then
    MsgBox "重複"
    del 行
    Target.ClearContents
    Target.Select
    GoTo Jump
  End If
  '
  del 行
  Application.EnableEvents = False
  mr = dicM(Cells(行, "A").Value & Cells(行, "K").Value)
  If mr > 0 Then Cells(行, "M").Resize(, 2).Value = _
          Sheets("Sheet2").Cells(mr, "M").Resize(, 2).Value
  
  Application.EnableEvents = True
  '
Jump:
  Set dic1 = Nothing
End Sub

Private Sub del(r As Long)
  Range(Cells(r, "m"), Cells(r, "n")).ClearContents
End Sub

Private Sub make_dicM()
Dim vntA, vntK
Dim i As Long, LastR As Long

  Set dicM = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet2")
    LastR = .Range("A65536").End(xlUp).Row
    vntA = .Range("A2", .Range("A" & LastR)).Value
    vntK = .Range("K2", .Range("K" & LastR)).Value
    For i = 1 To UBound(vntA)
      If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
        dicM(vntA(i, 1) & vntK(i, 1)) = i + 1
      End If
    Next
  End With
End Sub


===========================================================

Sheet2モジュールに

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dic2 As Object
Dim 行 As Long
Dim vntA, vntK
Dim i As Long, LastR As Long
  '
  行 = Target.Row
  If Target.Count > 1 Then Exit Sub
  If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
  If Cells(行, "A").Value = "" Then Exit Sub
  If Cells(行, "K").Value = "" Then Exit Sub
  '
  LastR = Range("A65536").End(xlUp).Row
  Set dic2 = CreateObject("Scripting.Dictionary")
  vntA = Range("A2", Range("A" & LastR)).Value
  vntK = Range("K2", Range("K" & LastR)).Value
  For i = 1 To UBound(vntA)
    If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
      dic2(vntA(i, 1) & vntK(i, 1)) = dic2(vntA(i, 1) & vntK(i, 1)) + 1
    End If
  Next
  '
  If dic2(Cells(行, "A").Value & Cells(行, "K").Value) > 1 Then
    MsgBox "重複"
    Target.ClearContents
    Target.Select
  End If
  Set dic2 = Nothing
End Sub

【28615】Re:検索該当行の複数セル値の取得について
発言  ponpon  - 05/9/10(土) 11:27 -

引用なし
パスワード
   こんにちは。
kobasanからちゃんとしたコードが出ているので、
私のは、どうでも良いのですが、
シートレイアウトと、指定したセルが違っているのかもしれません。
こちらでは、きちんと抽出されています。
両シートのセル位置を確認してください。

Sub test()
   Dim SH1 As Worksheet, SH2 As Worksheet
   Dim myR As Range, myR2 As Range
   Dim r As Range, c As Range
  
  ’両シートの1行目には、見出しがあるものとしています。 
   Set SH1 = Worksheets("単価マスタ")
   Set SH2 = Worksheets("代価表シート")
   Set myR = SH1.Range("A2", SH1.Range("A65536").End(xlUp)) ’A列
   Set myR2 = SH2.Range("A2", SH2.Range("A65536").End(xlUp)) ’A列
  
  ’代価表シートのA列の2行目から順に 
   For Each r In myR2 
  
  ’tを0に
    t = 0

  ’単価マスタシートのA列から順に 
    For Each c In myR

    ’代価表シートA列の値とマスタシートのA列の値が同じならば、 
     If r.Value = c.Value Then
   
     ’マスタシートのK列の値と代価表シートB列の値がおなじならば、 
      If c.Offset(0, 10).Value = r.Offset(0, 1).Value Then
       
       ’tに1をたして、もし、2になれば(同じ組み合わせが、
       ’2つ以上あれば)、msgを出して、検索をやめる。
       t = t + 1
       If t > 1 Then
        MsgBox "規格" & c.Offset(0, 10).Value & _
            "(" & c.Offset(0, 10).Address(0, 0) & ")" & _
            vbCrLf & "が重複しています"
       Exit For
       End If

       ’tが1ならば、代価表シートC列にマスタシートのM列の値を
       r.Offset(0, 2).Value = c.Offset(0, 12).Value

       ’代価表シートE列にマスタシートのN列の値を
       r.Offset(0, 4).Value = c.Offset(0, 13).Value
      End If
     End If
    Next
   Next

End Sub

【28616】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 11:31 -

引用なし
パスワード
   ▼kobasan さん:
早速の回答、誠にありがとうございます。
以下の点について、教えてください。

>行 = Target.Row
>If Target.Count > 1 Then Exit Sub
>If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub

Target.Rowは、検索したい項目を入力したセルの行No.を取得しているの
でしょうか。
Target.Countが1以上になる場合は、あるのでしょうか。
最後の行の判定条件の意味するところが分かりません。

お手数をおかけしてすみませんが、教えて頂けないでしょうか。

【28617】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 12:05 -

引用なし
パスワード
   ▼kobasan さん:
回答ありがとうございます。

先程より無限ループ云々という質問をさせて頂きましたが、
Application.EnableEvents = False

Application.EnableEvents = True

で〜にあったFor文内の無限ループが解消されました。

上記文、どのような意味があるか教えてください。

【28619】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 12:10 -

引用なし
パスワード
   ▼ponpon さん:

回答ありがとうございます。

ponponさんのご指摘で、再度、シート及びセル位置を確認しましたが、
問題はなさそうでした。

その後、kobasanさんからの回答で、

Application.EnableEvents = False

Application.EnableEvents = True

という表記がありました。

その表記を利用させて頂いたところ、問題になっていた無限ループが
解消されました。

上記文は、どのような意味があるのでしょうか。
何度も質問して申し訳ありませんが、教えて頂けないでしょうか。

【28622】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 14:02 -

引用なし
パスワード
   ▼BON8021 さん 今日は

【28616】の問いは解決されたと読みました。もしそうでないなら、また連絡してください。

>先程より無限ループ云々という質問をさせて頂きましたが、
>Application.EnableEvents = False
>〜
>Application.EnableEvents = True
>
>で〜にあったFor文内の無限ループが解消されました。
>
>上記文、どのような意味があるか教えてください。

Private Sub Worksheet_Change(ByVal Target As Range)
はChangeがあるようにチェンジイベントのプロージャ(Sub)です。
これは、ワークシート内のセルの値が変化したとき動くプロージャです。

たとえば、キーボードからセルの値を変えたとき、このプロージャは動きます。
また、VBAのコードでセルの値を変えたときも、このプロージャは動きます。

今回のコードでいうと、

  mr = dicM(Cells(行, "A").Value & Cells(行, "K").Value)
  If mr > 0 Then Cells(行, "M").Resize(, 2).Value = _
          Sheets("Sheet2").Cells(mr, "M").Resize(, 2).Value

この部分はセルの値を変えていますので、この変化に対して、チェンジイベントが発生して、 
Private Sub Worksheet_Changeをまた実行しようとします。
そうすると、このコードよって同じコードを繰り返し、無限ループが発生するようになります。
この無限ループを避けるために、

  Application.EnableEvents = False
  mr = dicM(Cells(行, "A").Value & Cells(行, "K").Value)
  If mr > 0 Then Cells(行, "M").Resize(, 2).Value = _
          Sheets("Sheet2").Cells(mr, "M").Resize(, 2).Value
  
  Application.EnableEvents = True

とします。
こうすると、
Application.EnableEvents = False

Application.EnableEvents = True
の間のコードによって値が変化してもの、チェンジイベントが発生しないようにるわけです。

Application.EnableEvents = False
によって、コードによって値が変化してもの、チェンジイベントが発生しないようにしています。

しかし、このまま放っておくと、Private Sub Worksheet_Changeが、それ以降全く動かなくなり
ますので、チェンジイベントを発生させたくない部分が終わったところで、

Application.EnableEvents = True

を宣言して、チェンジイベントを発生させるようにします。

詳しくはEnableEventsをヘルプで調べてみてください。

Private Sub Worksheet_Changeなどのチェンジイベントはすごい能力を持っていますが、
今回のように無限ループに入ることがあるので、扱いが難しい面もありますので気をつけ
てください。

【28623】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 14:16 -

引用なし
パスワード
   ▼BON8021 さん 今日は。

>以下の点について、教えてください。
>
>>行 = Target.Row
>>If Target.Count > 1 Then Exit Sub
>>If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub


>Target.Rowは、検索したい項目を入力したセルの行No.を取得しているの
>でしょうか。

はいそうです。

>Target.Countが1以上になる場合は、あるのでしょうか。

たとえば、複数セルをコピー貼り付けしたときを想定して、
Private Sub Worksheet_Change
を動かないようにしています。

>最後の行の判定条件の意味するところが分かりません。

>If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub

(Target.Column - 1) でA列(1列)
(Target.Column - 11) でK列(11列)

でA列,K列かどうかを判定しています。

(Target.Column - 1) * (Target.Column - 11) =0
ならA列かK列ということです。

【28624】Re:検索該当行の複数セル値の取得について
お礼  BON8021  - 05/9/10(土) 14:48 -

引用なし
パスワード
   ▼kobasan さん:

回答ありがとうございました。
kobasanさんの説明で非常に良く分かりました。

Private Sub Worksheet_Changeなどのチェンジイベントで、まさか、
そんなことが起きているとは、夢にも思いませんでした。

本当にありがとうございました。

【28627】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 15:15 -

引用なし
パスワード
   ▼kobasan さん:

いろいろとご教示頂き、ありがとうございます。

>>If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub

>(Target.Column - 1) でA列(1列)
>(Target.Column - 11) でK列(11列)

>でA列,K列かどうかを判定しています。

>(Target.Column - 1) * (Target.Column - 11) =0
>ならA列かK列ということです。

上記は、A列あるいはK列以外のセル値を変更しても、VBAが動かないと
いうことでしょうか。

【28628】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 15:35 -

引用なし
パスワード
   ▼BON8021 さん  今日は。

>>(Target.Column - 1) * (Target.Column - 11) =0
>>ならA列かK列ということです。
>
>If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
>上記は、A列あるいはK列以外のセル値を変更しても、VBAが動かないと
>いうことでしょうか。

正確に言うと、

Application.EnableEvents = True
の状態になっていますから、

If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub

この行まで動いて、A列あるいはK列以外なら、Then Exit Subでブロージャーの外に出るということです。

A列あるいはK列のセル値が変化したら、

If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub

の下の行のコードを実行します。

【28630】Re:検索該当行の複数セル値の取得について
お礼  BON8021  - 05/9/10(土) 16:21 -

引用なし
パスワード
   ▼kobasan さん:

回答ありがとうございます。
良く分かりました。

【28631】Re:検索該当行の複数セル値の取得について
質問  BON8021  - 05/9/10(土) 17:16 -

引用なし
パスワード
   ▼kobasan さん:

もう1点教えて頂きたいのですが、マスターシートの値を更新した場合、
転記用シートに反映させる手法はどうすれば、良いでしょうか。

vlookup関数のようなイメージを想定しており、特にm列(単価に相当)の
値がマスタ上で更新された場合、各転記用シートにm列の値を反映させたい
と思っております。

何卒、宜しくお願い致します。

【28632】Re:検索該当行の複数セル値の取得について
回答  kobasan  - 05/9/10(土) 19:35 -

引用なし
パスワード
   ▼BON8021 さん 今晩は。

>もう1点教えて頂きたいのですが、マスターシートの値を更新した場合、
>転記用シートに反映させる手法はどうすれば、良いでしょうか。
>
>vlookup関数のようなイメージを想定しており、特にm列(単価に相当)の
>値がマスタ上で更新された場合、各転記用シートにm列の値を反映させたい
>と思っております。

Sheet2モジュールのみ下記のコードに置き換えてください。
改良版、dictionary版のどちらでも動きます。

===========================
Sheet2モジュール

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dic2 As Object
Dim 行 As Long
Dim vntA, vntK
Dim i As Long, LastR As Long
Dim r As Range
  '
  行 = Target.Row
  If Target.Count > 1 Then Exit Sub
  If (Target.Column - 1) * (Target.Column - 11) _
              * (Target.Column - 13) <> 0 Then Exit Sub
  If Cells(行, "A").Value = "" Then Exit Sub
  If Cells(行, "K").Value = "" Then Exit Sub
  '
  LastR = Range("A65536").End(xlUp).Row
  Set dic2 = CreateObject("Scripting.Dictionary")
  vntA = Range("A2", Range("A" & LastR)).Value
  vntK = Range("K2", Range("K" & LastR)).Value
  For i = 1 To UBound(vntA)
    If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
      dic2(vntA(i, 1) & vntK(i, 1)) = dic2(vntA(i, 1) & vntK(i, 1)) + 1
    End If
  Next
  '
  Select Case Target.Column
  Case 1, 11
    If dic2(Cells(行, "A").Value & Cells(行, "K").Value) > 1 Then
      MsgBox "重複"
      Target.ClearContents
      Target.Select
    End If
  Case 13
    LastR = Sheets("Sheet1").Range("A65536").End(xlUp).Row
    For Each r In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & LastR))
    
      If (r.Value & r.Offset(0, 10).Value) = _
        (Cells(行, "A").Value & Cells(行, "K").Value) Then
        r.Offset(0, 12).Value = Target.Value
      End If
    Next
  End Select
  '
  Set dic2 = Nothing
End Sub

【28636】Re:検索該当行の複数セル値の取得について
発言  ponpon  - 05/9/10(土) 21:40 -

引用なし
パスワード
   こんばんは。kobasanさん、BON8021さん

ただいま帰宅しました。
今となっては、どうでもよいのですが・・・・

>その後、kobasanさんからの回答で、
>Application.EnableEvents = False
>Application.EnableEvents = True
>という表記がありました。

たぶんですが、シートモジュールにチェンジイベントのコードがあるまま
私ののコードを試されたのだと思います。

それで、

>問題になっていた無限ループが

発生したのだと思います。

9224 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free