エクセル VBA 複数あるセルの中身を１つのセルに表示させる

VBAを使って、出来ますでしょうか？

複数のセルに書かれている日付を
１つのセルにまとめて表示させたいと考えています。
日付は、
10/3,トマト（,で別セルとします）
4/5,トマト
5/6,レタス
3/4,レタス
1/3,レタス
のように縦に並んでいまして、
下の行（1/3)から１つのセルに入れていき
5/6,レタス,1/3・3/4・5/6と
[1/3・3/4・5/6]を１つのセルに入れ、
しかも出来れば「・」を間に入れて
１つのセルに表示させたいのです。

そして、同様にトマトにおいても
10/3,トマト,4/5・10/3と表示させ、
最終的には、
10/3,トマト,4/5・10/3
4/5,トマト
5/6,レタス,1/3・3/4・5/6
3/4,レタス
1/3,レタス
と表示させたいと思っております。
このとき、レタスとトマトの個数は数えなければ
わかりません。

大変難しいかと思いますが、
ぜひお知恵を貸して頂ければ幸いです。

No.1 ベストアンサー 回答者： Wendy02 回答日時： 2005/03/25 03:29

＞大変難しいかと思いますが、

この手の同様のご質問は、多いですね。

なお、A列の日付は降順、B列の文字列は昇順に並び、並び替えは、B列を優先させたものとします。
「,」区切りは、ないものとして解釈しました。
念のために、並び替えはします。
A列の日付は降順、B列の文字列は昇順に並び、並び替えは、B列を優先させたものとします。
データの先頭は、A1 にしました。
元のデータは消すことはありません。
これで、試してみてください。

'<標準モジュール>

Sub test1()
　Dim BaseArray As Variant
　Dim myCol As Integer
　Dim myRow As Long
　Dim Dat1 As String, Dat2 As String
　Dim i As Long
　Application.ScreenUpdating = False
　With Range("A1").CurrentRegion.Columns("A:B") '先頭の場所から二列の範囲
　.Sort Key1:=Range("B1"), Order1:=xlAscending, _
　　Key2:=Range("A1"), Order2:=xlDescending, _
　　Header:=xlGuess, OrderCustom:=1, _
　　MatchCase:=False, Orientation:=xlTopToBottom
　　'念のために並び替え
　　.Offset(, 2).Resize(, 1).ClearContents
　　.Offset(, 2).Resize(, 1).HorizontalAlignment = xlLeft
　　BaseArray = .Value
　　myCol = .Column
　　myRow = .Row
　End With
　Dat1 = BaseArray(UBound(BaseArray, 1), 2)
　Dat2 = Format$(BaseArray(UBound(BaseArray, 1), 1), "mm/dd")
　For i = UBound(BaseArray, 1) - 1 To LBound(BaseArray, 1) Step -1
　　If Dat1 = BaseArray(i, 2) Then
　　　Dat2 = Dat2 & "・" & Format$(BaseArray(i, 1), "mm/dd")
　　　Else
　　　Cells(i + myRow, myCol + 2).NumberFormat = "mm/dd"
　　　Cells(i + myRow, myCol + 2).Value = Dat2
　　　Dat1 = BaseArray(i, 2)
　　　Dat2 = Format(BaseArray(i, 1), "mm/dd")
　　End If
　Next i
　Cells(i + myRow, myCol + 2).NumberFormat = "mm/dd"
　Cells(i + myRow, myCol + 2).Value = Format$(Dat2, "mm/dd")
　Application.ScreenUpdating = True
End Sub

この回答への補足

申し訳ございません　もう一点教えてください。
現在B列を基準に判断していますが、
これがD列に入っていて、D列で判断したい
場合はどこを変えればよろしいのでしょうか？

配列は勉強していないので、勉強不足で申し訳ございません。

補足日時：2005/03/25 13:19

この回答へのお礼

この度は本当にありがとうございました。
いろいろと数字を打ち変えてみたら変更もうまくいきました。
また機会がありましたら宜しくお願いいたします。

お礼日時：2005/03/25 16:09

No.2 回答者： BLUEPIXY 回答日時： 2005/03/25 03:34

もう回答がありますが、せっかく作ったので回答させて頂きます。

日付のセルをアクティブセルにしてマクロを呼び出します。
日付を連結したデータを入れるセルは、あらかじめ消去しておいてください。自動的には、消去していません。（検査中に消していけばいいですけど）
'----------------------------------------------
Public Sub dateCat() '先頭の日付のセルをアクティブセルで呼び出し
Dim name, list
Dim a(), i, x
Dim r As Range, top As Range, bottom As Range

Do While ActiveCell.Value <> ""
Set top = ActiveCell
name = ActiveCell.Offset(0, 1).Value '名前を取り出す
i = 0
Do While name = top.Offset(i, 1).Value
i = i + 1 '名前が同じ間
Loop
Set bottom = top.Offset(i - 1, 0)
Set r = Range(top, bottom)
ReDim a(r.count)
i = 0
For Each x In r
a(i) = x.Value
i = i + 1
Next
Call ArraySort(a, True)
list = ""
For Each x In a
list = list & Format(x, "m/d・")
Next
list = Left(list, Len(list) - 1) '最後の・を取る
ActiveCell.Offset(0, 2).Value = list '最初の行にリストを入力
bottom.Offset(1, 0).Activate 'アクティブセルの設定
Loop
End Sub
Private Sub ArraySort(a, Optional ascending = 0) '配列をソートする、規定値は大きいもの順
Dim wk, i As Integer, j As Integer, k As Integer
Dim n
n = UBound(a)
k = n \ 2
Do While (k > 0) 'シェルソート
For i = 0 To n - k
j = i
Do While (j >= 0)
If a(j) > a(j + k) Then
wk = a(j)
a(j) = a(j + k)
a(j + k) = wk
j = j - k
Else
Exit Do
End If
Loop
Next
k = k \ 2
Loop
If ascending = 0 Then '逆順にする
i = 0: j = n
Do Until (i >= j)
wk = a(i)
a(i) = a(j)
a(j) = wk
i = i + 1: j = j - 1
Loop
End If
End Sub