EXCEL VBAによる重複セル抽出、結合について

VBA初心者です。Excel2007、Windows7を使用しています。

A列からAG列、平均1000行程度の顧客データがあります。
1行目は見出しです。

その中でAB列が重複する場合、D列のみ結合したいです。
なお、結合する際、間に「,」を入れたいです。

例）
D　E　F　...　AA　AB
123　○　×　...　△　□
456　○　×　...　△　■
789　○　×　...　△　□

上記の場合、D2が123789　D3が456　D4が123789

重複するセルは、続けてや、とびとびの場合もあります。

ご教授頂けないでしょうか。
宜しくお願い致します。

No.1 ベストアンサー 回答者： tom04 回答日時： 2015/09/02 21:47

こんばんは！

＞上記の場合、D2が123789　D3が456　D4が123789
とありますが
＞なお、結合する際、間に「,」を入れたいです。
というコトですので、
D2・D4は
123,789
のように表示させてみました。

元データはSheet1にあるとします。
Sheet2を作業用のSheetとして使用していますので、
Sheet2は使っていない状態にしておいてください。
標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim str As String, myRng As Range, wS As Worksheet
Application.ScreenUpdating = False
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "AB").End(xlUp).Row
Set myRng = Range(.Cells(2, "D"), .Cells(lastRow, "D"))
.Range("AB:AB").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("AB:AB").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A")
wS.Range("B:B").ClearContents
myRng.SpecialCells(xlCellTypeVisible).Copy wS.Range("B1")
str = ""
If wS.Cells(Rows.Count, "B").End(xlUp).Row > 1 Then
For k = 1 To wS.Cells(Rows.Count, "B").End(xlUp).Row
str = str & wS.Cells(k, "B") & ","
Next k
myRng.SpecialCells(xlCellTypeVisible).Value = Left(str, Len(str) - 1)
End If
Next i
.AutoFilterMode = False
.Columns("D:D").AutoFit
End With
wS.Cells.Clear
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

早々にありがとうございます！
思った通りの動きで助かりました。本当にありがとうございます！！

お礼日時：2015/09/03 11:13