VBA 同じ番号の情報をまとめる

Question

画像のように、同じ番号の場合に日付と商品を1行にまとめたいです。

以下のように1行下のセルと比較することを考えましたが

    Dim i As Long
    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
      If i = i + 1 Then
      Else
    next i

どのように記述すればよいか全くわからなくなってしまいました。
良い比較方法と、行をまとめる記述をどなたかご教授下さい。

Answer 1

私も書いてみました。
日付のところだけ特殊なのでちょっと面倒ですね。

Sub test()
    Dim r1, r2, cnt As Long
    Dim pre
    
    r1 = 2
    r2 = 2
    pre = ""
    
    Do While Not IsEmpty(Cells(r1, 2))
        If pre <> Cells(r1, 2) Then
            cnt = WorksheetFunction.CountIf(Columns(2), Cells(r1, 2))
            Cells(r2, 6) = Format(Cells(r1, 1), "'m/d")
            Cells(r2, 7) = Cells(r1, 2)
            Cells(r2, 8) = Cells(r1, 3)
            If cnt <> 1 Then
                For Each d In Cells(r1 + 1, 1).Resize(cnt - 1, 1)
                    If d <> Cells(d.Row - 1, 1) Then
                        Cells(r2, 6) = Cells(r2, 6) & "," & Day(d)
                    End If
                Next
                Cells(r2, 8) = Join(WorksheetFunction.Transpose(Cells(r1, 3).Resize(cnt, 1)), "+")
            End If
            pre = Cells(r1, 2)
            r2 = r2 + 1
        End If
        r1 = r1 + 1
    Loop
End Sub

Comments

[kai_keitai]

そっか、Join関数ね、その手がありましたね。
これだと、ソースコードがスッキリしますね。

[ttyp03]

日付の方にも使えるともっとスッキリするんですけどね。
いい書き方が思いつかなかったです。
Rangeの各セルから日を取り出して配列化、更に重複値を削除、というのを一発でできれば。。。

[sazi]

UNIQUE()あたりが使えないでしょうか。
http://officetanaka.net/excel/function/function/unique.htm
というか、スピル関数だけで出来そうな気がする
スピルとUNIQUE関数で動的ピボットテーブルを作る
https://www.yosato.net/?p=3469

[ttyp03]

職場のExcelは2013なので使えないです。。。

[sazi]

あ、ええ、レガシーも大事ですよね。

[kai_keitai]

スピル関数が使えれば、VBAは不要ですよね・・・

Answer 2

Excelのバージョンが最新であれば、関数を使って実現できます。

F列には、

 =TEXTJOIN(", ",TRUE,TEXT(UNIQUE(FILTER(_Data1[日付],(_Data1[No]=G2))),"m/d"))

G列には、

    =UNIQUE(_Data1[No])

H列には、

 =TEXTJOIN(" + ",TRUE,TEXT(UNIQUE(FILTER(_Data1[商品],(_Data1[No]=G2))),"m/d"))

最新のバージョンが使えない場合は、VBA一択ですね。
配列を使って実現します。
昔からあるオーソドックスな手法です。

Option Explicit

Sub TranceSheet()
    Dim RangeData
    RangeData = Range("A1").CurrentRegion.Value
    
    Dim x As Integer
    Dim y As Integer
    x = UBound(RangeData)
    y = Int(Range("A1").CurrentRegion.Count / x)
    
    Dim i As Integer
    Dim j As Integer
    Dim Date1 As String
    Dim Date2 As Date
    Dim No1 As Integer
    Dim Code1 As String
    Dim Code2 As String
    
    For i = 2 To x
        If i = 2 Then
            No1 = RangeData(i, 2)
            j = 2
        End If
        If i > 2 And RangeData(i, 2) <> No1 Then
            Range("F" & j).Value = Date1
            Range("G" & j).Value = No1
            Range("H" & j).Value = Code1
            Date1 = ""
            Date2 = 1
            No1 = RangeData(i, 2)
            Code1 = ""
            j = j + 1
        End If
        
        If RangeData(i, 1) <> Date2 Then
            If Date1 <> "" Then
                Date1 = Date1 & ", " & Format(RangeData(i, 1), "m/d")
            Else
                Date1 = Format(RangeData(i, 1), "m/d")
            End If
            Date2 = RangeData(i, 1)
        End If
        If RangeData(i, 3) <> Code2 Then
            If Code1 <> "" Then
                Code1 = Code1 & " + " & RangeData(i, 3)
            Else
                Code1 = RangeData(i, 3)
            End If
            Code2 = RangeData(i, 3)
        End If
        
    Next i
    
    Range("F" & j).Value = Date1
    Range("G" & j).Value = No1
    Range("H" & j).Value = Code1

End Sub

Answer 3

Option Explicit

Sub test()
    Dim ixOld As Long
    Dim ixNew As Long
        
    For ixOld = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        For ixNew = 2 To Cells(Rows.Count, "G").End(xlUp).Row
            If Cells(ixOld, "B").Value = Cells(ixNew, "G").Value Then Exit For
        Next
        
        If ixNew > Cells(Rows.Count, "G").End(xlUp).Row Then
            Cells(ixNew, "F").Value = "'" & Cells(ixOld, "A").Text
            Cells(ixNew, "G").Value = Cells(ixOld, "B").Value
            Cells(ixNew, "H").Value = "'" & Cells(ixOld, "C").Value
        Else
            Cells(ixNew, "F").Value = Cells(ixNew, "F").Value & "," & Split(Cells(ixOld, "A").Text, "/")(1)
            Cells(ixNew, "H").Value = Cells(ixNew, "H").Value & "+" & Cells(ixOld, "C").Value
        End If
    Next
End Sub

For ixNew = 2 To Cells(Rows.Count, "G").End(xlUp).Row
If Cells(ixOld, "B").Value = Cells(ixNew, "G").Value Then Exit For
Next

というようにすると、
ループカウンターがNextを通るたびにループカウンターが+1されるので、
最後まで回るとちょうど新しく記入する行番号になります。
ループを途中で抜けると、見つかった行番号になるので、
このように検索していくのがコツになります。

あとは、ループが最後まで回ったかどうかで条件分岐し、記入方法を変えればOKかと
思います。

Comments

[kai_keitai]

確かに、ループは正しく動くと思います。
しかし、値を正しく比較していないので、正しい結果は出ないと思います。

また、質問者は、ユニークの値を出したいとあります。
これでは、同じ日付やコードがセルに代入されてしまいます。