Excel VBA質問箱 IV

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

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


52943 / 76732 ←次へ | 前へ→

【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

0 hits

【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 回答

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