Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2010)
検索条件が一致する全ての値の抽出
投稿日時: 21/03/17 20:39:37
投稿者: ひろまさ

お願いがございます。
約7万件のデータより番号が一致する全ての管理番号を抽出して、
転記を行いたいのですが、アドバイスをお願い出来ないでしょうか。
現在、作成した処理では以下のようになります。
 
■Sheet1(参照元)
番号 管理番号
111  3000
222  3100
333  3200
444  3300
222  3400
 
 
■Sheet2(転記先)
管理番号 番号
3000   111
3100   222
3200   333
3300   444
3100   222
 
それを以下のように、同じ番号が複数存在する場合は2個目以降の
管理番号を同一行の右のセルに、順に転記をしたいのです。
 
■Sheet2(転記先)
管理番号 番号 管理番号2 管理番号3
3000   111
3100   222  3400
3200   333
3300   444
 
現在の記述は以下の通りです。
 
Set rng検索値 = Worksheets("Sheet2").Range("B2:B100001")
Set rng検索範囲 = Worksheets("Sheet1").Range("A2:A100001")
Set rng出力範囲 = Worksheets("Sheet2").Range("B2:B100001")
 
Call Ketsugo(rng検索値, rng検索範囲, 2, rng出力範囲)
 
Sub Ketsugo(ByVal rng検索値 As Range, _
            ByVal rng検索範囲 As Range, _
            ByVal 列位置 As Integer, _
            ByVal rng出力範囲 As Range)
             
Dim i As Long
Dim ary()
Dim myDic As New Dictionary
For i = 1 To rng検索範囲.Rows.Count
    If Not myDic.Exists(rng検索範囲(i, 1).Value) Then
        myDic.Add rng検索範囲(i, 1).Value, rng検索範囲(i, 1).Offset(, 列位置 - 1).Value
    End If
Next
ReDim Preserve ary(1 To rng出力範囲.Rows.Count, 1 To 2)
For i = 1 To rng検索値.Rows.Count
    ary(i, 1) = myDic.Item(rng検索値(i, 1).Value)
Next
rng出力範囲.Value = ary
     
End Sub
 
以上ですが、どのように変更をすればよいのかアドバイスをよろしくお願い致します。
また、違う記述の方法があればご教示を頂ければ幸いです。

回答
投稿日時: 21/03/17 21:53:13
投稿者: simple

私だったらこういうレイアウトにしますね。
こういう前提でコード書いたので、
必要ならそちらで修正してください。
 

     A列     B        C          D
1    番号    管理番号 管理番号2  管理番号3
2    111     3000            
3    222     3100      3400  
4    333     3200            
5    444     3300            

スピードは考えておらず、分かり易いことを重視しました。
Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim dic As Object
    Dim rng As Range
    Dim p   As Long
    Dim k   As Long
    Dim r   As Long
    Dim s1  As String
    Dim s2  As String

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Set dic = CreateObject("Scripting.Dictionary")

    p = 1
    For k = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
        s1 = ws1.Cells(k, "A").Value
        s2 = ws1.Cells(k, "B").Value

        If Not dic.Exists(s1) Then 'まだ「番号」は登録されていない
            p = p + 1
            dic(s1) = p     'key:番号   item:転記先の行番号 のdictionary
            ws2.Cells(p, "A").Value = s1
            ws2.Cells(p, "B").Value = s2
        Else        '既に「番号」がある
            r = dic(s1)
            Set rng = ws2.Cells(r, Columns.Count).End(xlToLeft).Offset(, 1)
            rng.Value = s2
        End If
    Next
End Sub

なお、提示されたコードでは、Sheet2の rng検索値 に既に情報が入っているかのような
ものとなっていますが、Sheet2は見出し行を除いて空白という前提を採っています。

投稿日時: 21/03/17 22:56:42
投稿者: ひろまさ

simpleさんご回答ありがとうございます。
申し訳ございません。
私の説明不足です。
 
■Sheet1(参照元)
番号 管理番号
111  3000
222  3100
333  3200
444  3300
222  3400
 
■Sheet2(転記先)
管理番号 番号
     111
     222
     333
     444
     222
 
この状態で、Sheet2の番号を検索値として、Sheet1の番号を
参照して一致した場合、管理番号をSheet2に転記したいのです。
 
結果は以下の通りを望んでいます。
 
■Sheet2(転記先)
管理番号 番号 管理番号2 管理番号3
3000   111
3100   222  3400
3200   333
3300   444
 
大変申し訳ございませんがよろしくお願い致します。

投稿日時: 21/03/17 23:20:50
投稿者: ひろまさ

simpleさん何度も大変申し訳ございません。
最初のSheet2の状態は
 
■Sheet2(転記先)
管理番号 番号
      111
     222
     333
     444
     222
 
ではなく、
 
■Sheet2(転記先)
管理番号 番号
      111
     222
     333
     444
です。

回答
投稿日時: 21/03/17 23:40:37
投稿者: simple

Sheet2に予めセットされている「番号」は、
Sheet1にある「番号」の重複を除いたものと一致するんでしょう?
であれば、予めあってもなくても、私のコードで同じ結果になると思いますが。
(列の順序はあなたのほうで調整してください。)
 
もし違うとしたら、
・Sheet1にしかないもの
・Sheet2にしかないもの
はどのように扱うんですか?
仕様を正確に表現して下さい。

回答
投稿日時: 21/03/17 23:50:15
投稿者: WinArrow
投稿者のウェブサイトに移動

引用:
Set rng検索値 = Worksheets("Sheet2").Range("B2:B100001")
Set rng検索範囲 = Worksheets("Sheet1").Range("A2:A100001")
Set rng出力範囲 = Worksheets("Sheet2").Range("B2:B100001")

 
  
rng検索値 とrng出力範囲 が、同じセル範囲になっています。

回答
投稿日時: 21/03/18 00:00:23
投稿者: simple

ああ、Sheet2の番号のほうが範囲が狭いんですね。
それなら、
・最初にSheet2によって、番号と行番号の対応関係を辞書にもたせます。
・次に,SHeet1のデータを順次読んで、
  辞書に存在するデータだけをSheet2だけに書き込んでいけばよいです。
  同じように最右列から左にジャンプして、その右に順次書き込んでいけばよいでしょう。
少し手を入れれば、修正できるはずです。
 
とりあえず、私はここまでとさせていただきます。

投稿日時: 21/03/18 00:09:36
投稿者: ひろまさ

simpleさん再度、ご回答ありがとうございます。
列の順序の件につきましては承知しました。
 
Sheet1(参照元)とSheet2(転記先) の違いですが、Sheet1には
重複した番号が存在していますが、それぞれ管理番号が異なります。
従いまして、番号が重複している値につきましてはSheet1において、
それぞれ管理番号を転記したいのです。
 
以下は、simpleさんからご回答を頂いたレイアウトです。
 
  A列   B    C     D
1 番号 管理番号 管理番号2 管理番号3
2 111   3000
3 222   3100  3400
4 333   3200
5 444   3300

回答
投稿日時: 21/03/18 08:30:42
投稿者: WinArrow
投稿者のウェブサイトに移動

提案
 
転送元をDictionaryに登録していますが、
 
番号をKeyに、
管理番号(配列化して)をITEMに
した方が、よいのではないでしょうか?

回答
投稿日時: 21/03/18 10:18:01
投稿者: WinArrow
投稿者のウェブサイトに移動

↑ITEMに配列を格納する方法を提案したが
↓のような方法もあります
参考例
 
  Dim myDic As Object, myKey
  Dim c, myVal
  Dim i As Long
    Set myDic = CreateObject("Scripting.Dictionary")
    '---myDicにKeyとItemを格納する
    For i = 2 To 7
        If Not myDic.exists(Cells(i, 1).Value) Then
            myDic.Add Cells(i, 1).Value, Cells(i, 2).Value
        Else
            myDic(Cells(i, 1).Value) = myDic(Cells(i, 1).Value) & "," & Cells(i, 2).Value
        End If
    Next i
    '---Itemを取り出す
    For i = 2 To 7
        Cells(i, 5).Value = myDic.Item(Cells(i, 4).Value)
    Next i
 
  Set myDic = Nothing

投稿日時: 21/03/18 20:08:06
投稿者: ひろまさ

simpleさん、WinArrowさん、いろいろとアドバイスをして頂き
ありがとうございました。
頑張ってみます。