新規会員登録における電話番号登録必須化のお知らせ

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

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

そして、同様にトマトにおいても
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,レタス
と表示させたいと思っております。
このとき、レタスとトマトの個数は数えなければ
わかりません。

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

教えて!goo グレード

A 回答 (2件)

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


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

なお、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
    • good
    • 0
この回答へのお礼

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

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

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


日付のセルをアクティブセルにしてマクロを呼び出します。
日付を連結したデータを入れるセルは、あらかじめ消去しておいてください。自動的には、消去していません。(検査中に消していけばいいですけど)
'----------------------------------------------
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
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

教えて!goo グレード

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング