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

質問

前回とほぼ同じ質問なのですが、宜しくお願いします。

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

そして、同様にトマトにおいても行い、
最終的には、
10/3,トマト,長野,4/5・10/3
4/5,トマト,長野
5/7,トマト,神奈川,5/7
5/6,レタス,千葉,5/6
3/4,レタス,東京,1/3・3/4
1/3,レタス,東京
と表示させたいと思っております。
一致材料は２つあり、
品物と産地が一致することが必要です。
このとき、レタスとトマトの個数は数えなければ
わかりません。

ここで教えていただいたことを、実際には
６個の項目が一致して始めて日付を１セルに
まとめたいと思っています。しかも間には
判断とは関係ない列も含まれ、６項目が
横に連続はしていません。

配列を使えば良いみたいですが、勉強不足です。
大変難しいかと思いますが、
ぜひお知恵を貸して頂ければ幸いです

回答No.1

BLUEPIXY · ベストアンサー

参考ＵＲＬの
Public Sub dateCat()～End Subの部分を以下の部分で置き換えてください。
実行方法は、参考ＵＲＬと同じです。
月日が1つだけの場合は自動的に書式が変わってしまうかもしれませんが、その場合は手動で書式を設定してやってください。
'---------8<------------8<-------------
Public Sub dateCatM() '先頭の日付のセルをアクティブセルで呼び出し
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 & ActiveCell.Offset(0, 2).Value '比較部分を取り出す
i = 0
Do While name = top.Offset(i, 1).Value & top.Offset(i, 2).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, 3).Value = list '最初の行にリストを入力
bottom.Offset(1, 0).Activate 'アクティブセルの設定
Loop
End Sub
'---------8<------------8<-------------
＞実際には６個の項目が一致して
参考ＵＲＬと今回のソースを見比べてもらえばわかりますが、変更したのは３カ所だけです。
>name = ActiveCell.Offset(0, 1).Value & ActiveCell.Offset(0, 2).Value '比較部分を取り出す
>Do While name = top.Offset(i, 1).Value & top.Offset(i, 2).Value
>ActiveCell.Offset(0, 3).Value = list '最初の行にリストを入力
nameに関する処は、条件が増えるたびに
& ActiveCell.Offset(0, 2).Value
を追加していけばよいです。数字の２の部分を列数に合わせて増やします。アクティブセルの位置が０として数えます。
最後に日付をセットしている行も３の部分を位置に合わせて変更します。

参考URL：

http://okweb.jp/kotaeru.php3?qid=1289626

お礼

本当にありがとうございました。
これで業務が大幅にスムーズに進みます。
また機会がありましたら宜しくお願いいたします。

回答No.2

taocat

おはようございます。
配列はちょと難しいということなので配列なしを。(^^;;;

●見出しが１行目、データは２行目から
--------------------------------------------------
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　Ｅ　　Ｆ
１　日付　項目２　種類　項目４　産地　項目６
--------------------------------------------------

●結果は、同じシートで以下の列に２行目から
--------------------------------------------------
　　Ｋ　　　Ｌ　　　Ｍ　　Ｎ
１　日付　種類　産地　全日付
--------------------------------------------------

Sub Test()

Dim R As Long

Dim Krow As Long　　　'結果書込み行
Dim KekkaRow As Long　　'全日付結果を書き込む行
Dim Kekka　　　　　　　'全日付結果溜め込み用

Dim Syurui　　'種類比較用
Dim Sanchi　　'産地比較用

'種類、産地、日付でソート（マクロ記録で取る）

Range("A1").Select
Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("E2") _
, Order2:=xlDescending, Key3:=Range("A2"), Order3:=xlDescending, Header _
:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
, SortMethod:=xlPinYin

'処理スタート

　Krow = 2
　KekkaRow = Krow
　　Cells(Krow, "K") = Cells(2, "A")
　　Cells(Krow, "L") = Cells(2, "C")
　　Cells(Krow, "M") = Cells(2, "E")
　　Kekka = Format(Cells(2, "A"), "mm/dd")

　Syurui = Cells(2, "C")
　Sanchi = Cells(2, "E")

　For R = 3 To Range("A65536").End(xlUp).Row
　　If Syurui = Cells(R, "C") And Sanchi = Cells(R, "E") Then

　　　　Krow = Krow + 1
　　　　Cells(Krow, "K") = Cells(R, "A")
　　　　Cells(Krow, "L") = Cells(R, "C")
　　　　Cells(Krow, "M") = Cells(R, "E")
　　　　Kekka = Format(Cells(R, "A"), "mm/dd") & "・" & Kekka

　　Else

　　Cells(KekkaRow, "N") = Kekka

　　　　Krow = Krow + 1
　　　　KekkaRow = Krow
　　　　Cells(Krow, "K") = Cells(R, "A")
　　　　Cells(Krow, "L") = Cells(R, "C")
　　　　Cells(Krow, "M") = Cells(R, "E")
　　　　Kekka = Format(Cells(R, "A"), "mm/dd")

　　　　Syurui = Cells(R, "C")
　　　　Sanchi = Cells(R, "E")

　　End If

　Next R

　　Cells(KekkaRow, "N") = Kekka

　　Columns("K:K").NumberFormatLocal = "mm/dd"
　　Columns("K:N").AutoFit

End Sub
-------------------------------------------------

処理の流れが分かるように似たようなコードもサブルーチンにしてありません。
また、画面の状況が目で確かめらるようにScreenUpdatingは入れてありません。

この際ですから配列もしっかり勉強しませう。(^^;;;

以上です。

お礼

この度はありがとうございました。
これからは配列の勉強もちゃんとしたいと思います。