ExcelVBAで重複するデータを表示するには？

VBAで重複するデータを検索し，一致するデータがある場合は，
その隣のセルを別シートにて横方向に表示させたいと思っています。

どのようにしたら，良ろしいでしょうか？

具体的には，下記のSheet1 のデータを元に，VBAでSheet2を作成したいと考えています。

<<Sheet1>>
社名 　　品名
-----＋------＋
A社 　　　 PC
A社 　　プリンタ
B社 　 　モデム
B社 　　　 PC
A社 　 　スキャナ
C社 　　　 PC


<<Sheet2>>
社名 　　 　品名1 　　　 品名2　　　 品名3
-----＋------＋--------＋--------＋
A社 　　　　PC 　　　プリンタ　 　　スキャナ
B社 　　　モデム　　　 PC
C社 　　　　 PC

関連して・・・
　・Sheet2の社名は重複表示させない
　・品名1，品名2，品名3の順番は，Sheet1にて1行目から検索してヒットする順番で表示
　・重複するデータがない場合（C社），そのまま社名と品名をSheet2に表示

以上，よろしくお願い致します。

No.4 回答者： 30246kiku 回答日時： 2012/11/16 12:19

Excel の関数等不慣れなので、そういう人が考えたら・・・の例になるか？も

重複排除・・・ Dictionary を使ってしまいます。
今回の場合、社名がキーで品名が内容

社名は出現順、品名も出現順（ただし、重複する品名は覚えない）
以下の関数を標準モジュールに記述しておきます。

Public Sub CngShowPtn(rng As Range, toRng As Range)
　　Dim dic As Object
　　Dim v As Variant, vr As Variant
　　Dim bNxt As Boolean
　　Dim i As Long, iv As Long, ivmax As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　With rng
　　　　i = 1
　　　　While (.Offset(i) <> "")
　　　　　　bNxt = True
　　　　　　v = dic.Item(.Offset(i).Value)
　　　　　　If (Not IsArray(v)) Then
　　　　　　　　ReDim v(0)
　　　　　　Else
　　　　　　　　For Each vr In v
　　　　　　　　　　If (vr = .Offset(i, 1).Value) Then
　　　　　　　　　　　　bNxt = False
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　If (bNxt) Then ReDim Preserve v(UBound(v) + 1)
　　　　　　End If
　　　　　　If (bNxt) Then
　　　　　　　　v(UBound(v)) = .Offset(i, 1).Value
　　　　　　　　dic.Item(.Offset(i).Value) = v
　　　　　　End If
　　　　　　i = i + 1
　　　　Wend
　　End With

　　If (dic.Count > 0) Then
　　　　With toRng
　　　　　　i = 1
　　　　　　ivmax = 0
　　　　　　For Each v In dic.Keys
　　　　　　　　vr = dic.Item(v)
　　　　　　　　iv = UBound(vr) + 1
　　　　　　　　If (iv > ivmax) Then ivmax = iv
　　　　　　　　.Offset(i) = v
　　　　　　　　.Offset(i, 1).Resize(, iv) = vr
　　　　　　　　i = i + 1
　　　　　　Next
　　　　　　.Offset(0) = rng
　　　　　　For i = 1 To ivmax
　　　　　　　　.Offset(0, i) = rng.Offset(0, 1) & i
　　　　　　Next
　　　　End With
　　End If
　　Set dic = Nothing
End Sub


使い方は、どこの表を、そして結果をどこに表示する
を Range で指定します。
以下を実行してみた結果は、添付図のようになります。

Public Sub test()
　　Call CngShowPtn(Range("A1"), Range("D2"))
　　Call CngShowPtn(Range("A9"), Range("D10"))
End Sub

また、シートを修飾して指定したりします。

例）
　　Call CngShowPtn(Worksheets("Sheet1").Range("A1") _
　　　　　　　　　　　　, Worksheets("Sheet2").Range("A1"))

No.3 回答者： mt2008 回答日時： 2012/11/16 11:04

ANo.2です。

画像をせっかく作ったのに添付し忘れていました。

No.2 回答者： mt2008 回答日時： 2012/11/16 10:57

簡単なものを作ってみました。

該当社名が一番最初に登場する行の右に品名を追加していき、最後に社名登場が2番目以降の不要な行を削除して形を整えています。


Sub Sample()
　　Dim nMax, nMatch, nCol, sString, i
　　'Sheet1からSheet2にコピー
　　Sheets("Sheet1").Cells.Copy
　　Sheets("Sheet2").Range("A1").Select
　　ActiveSheet.Paste
　　nMax = Cells(Rows.Count, 1).End(xlUp).Row
　　For i = 2 To nMax 'データがあるのは2行目から
　　　　nMatch = WorksheetFunction.Match(Cells(i, 1), Range("A:A"), 0)
　　　　If nMatch <> i Then
　　　　　　'品名を右に表示
　　　　　　sString = sString & i & ":" & i & ","　'不要行削除用
　　　　　　nCol = Cells(nMatch, 1).End(xlToRight).Column
　　　　　　Cells(nMatch, nCol + 1) = Cells(i, 2)
　　　　End If
　　Next i
　　'不要な行の削除
　　sString = Left(sString, Len(sString) - 1)
　　Range(sString).Delete Shift:=xlUp
End Sub

No.1 回答者： cj_mover 回答日時： 2012/11/16 07:47

こんにちは。

技術的に簡易なものを選んで書いてみました。
ＶＢＡに慣れたら、配列とか外部オブジェクトとか使いたくなると思いますが、
そこまで望んでいるようには見受けられなかったので、易しい方法にします。
具体的なご要望あれば、一応お応えするつもりです。

指定が漏れている点、都合上、すべて可変にして書いています。
以下こちらで仮に設定したもの。
　社名は、Ａ列にある　　nKeyCol = 1
　品名は、Ｂ列にある　　nField2Col = nKeyCol + 1
　統合するデータの元の列は（Ｂ列に始まり）Ｂ列で終る　　nFieldsEndCol = nField2Col + 0
　レコードの先頭行は３行め　　nTopRow = 3　

Sheet2 のフィールド名を設定する記述は省きました。



Sub Re7799914cc()
　　Dim vTemp　 As Variant
　　Dim wshtP　 As Worksheet
　　Dim flgA()　As Boolean
　　Dim nKeyCol　　　　 As Long
　　Dim nField2Col　　　As Long
　　Dim nFieldsEndCol　 As Long
　　Dim nTopRow　　　　 As Long
　　Dim nBottomRow　　　As Long
　　Dim nC　As Long
　　Dim nR　As Long
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim k　 As Long

　　Set wshtP = Sheets("Sheet2") '　　　 ◆指定

　　nKeyCol = 1 '　　　　　　　　　　　　◆指定
　　nField2Col = nKeyCol + 1 ' 2 '　　　 ◆指定
　　nFieldsEndCol = nField2Col + 0 ' 2 ' ◆指定

　　With Sheets("Sheet1") '　　　　　　　◆指定
　　　　nTopRow = 3 '　　　　　　　　　　◆指定
　　　　nBottomRow = .Cells(Rows.Count, nKeyCol).End(xlUp).Row

　　　　ReDim flgA(nTopRow To nBottomRow) As Boolean

　　　　nR = nTopRow - 1
　　　　For i = nTopRow To nBottomRow
　　　　　　If Not flgA(i) Then
　　　　　　　　nR = nR + 1
　　　　　　　　vTemp = .Cells(i, nKeyCol).Value
　　　　　　　　wshtP.Cells(nR, nKeyCol).Value = vTemp

　　　　　　　　nC = nField2Col - 1
　　　　　　　　For k = nField2Col To nFieldsEndCol
　　　　　　　　　　nC = nC + 1
　　　　　　　　　　wshtP.Cells(nR, nC).Value = .Cells(i, k).Value
　　　　　　　　Next k

　　　　　　　　For j = i + 1 To nBottomRow
　　　　　　　　　　If Not flgA(j) Then
　　　　　　　　　　　　If .Cells(j, nKeyCol).Value = vTemp Then
　　　　　　　　　　　　　　flgA(j) = True
　　　　　　　　　　　　　　For k = nField2Col To nFieldsEndCol
　　　　　　　　　　　　　　　　nC = nC + 1
　　　　　　　　　　　　　　　　wshtP.Cells(nR, nC).Value = .Cells(j, k).Value
　　　　　　　　　　　　　　Next k
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　End If
　　　　Next i
　　End With

　　Set wshtP = Nothing
　　Erase flgA
End Sub