VBA 縦のデータを横にするコード

質問

VBA初心者です。

縦に複数の顧客が存在して、その顧客の出荷日をセル一つにまとめたいのですが、全くがやり方が
わかりません。すいませんが、教えて頂けると幸いです。

【例】
■シート1
　　　A列　　　B列
1　　番号　　出荷日
2　　005　　　2014/5/1
3　　001　　　2014/5/5
4　　003　　　2014/5/23
5　　003　　　2014/5/14
6　　001　　　2014/5/3
7　　005　　　2014/5/8
8　　001　　　2014/5/16
9　　001　　　2014/5/4

↓↓↓↓↓↓↓↓↓↓
■シート2
　　　A列　　　B列
1　　001　　　 2014/5/5、2014/5/3、2014/5/16、2014/5/4
2　　003　　　 2014/5/23、2014/5/14
3　　005　　　 2014/5/1、2014/5/8

上記のように処理することは可能でしょうか。

宜しくお願い致します。

回答No.1

tom04

こんばんは！

シート1・シート2　とあるので、Excelだという解釈で・・・

複数の日付を別セル表示させるのではなく、B列1列だけに表示させたいのですね？
一例です。
標準モジュールにコピー＆ペーストしてマクロを実行してみてください。
尚、Sheet1、A列の表示形式はユーザー定義から　000　と3桁表示させているという前提です。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long, str As String, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
.Range("B1").Copy wS.Range("C1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("B1"), unique:=True
wS.Range("B1").Sort key1:=wS.Range("B1"), order1:=xlAscending, Header:=xlYes
For i = 2 To wS.Cells(Rows.Count, "B").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=Format(wS.Cells(i, "B"), "000")
Range(.Cells(2, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A2")
For k = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
str = str & wS.Cells(k, "A") & ", "
Next k
wS.Cells(i, "C") = Left(str, Len(str) - 2)
str = ""
wS.Range("A:A").Clear
Next i
wS.Range("A:A").Delete
wS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.AutoFilterMode = False
wS.Columns.AutoFit
wS.Activate
wS.Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub

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

お礼

早急のご回答誠にありがとうございます。
そのままモジュールにコピペしたら、できました!!!
ずっと悩んでたので、稼働しました。
ありがとうございます!(^^)!