エクセル セル内の文字を条件に一致した時に結合する方法

質問

下表の表で同じ品番で色が複数あるときに本数を先頭行に集計しているのですが色を備考欄のセルに結合して表示する関数又はマクロで方法を教えてください。
色が重複する時は色の本数表示はしません。（A1はBが2本ありますがB*2とはしません）

No.　　品番　　本数　　色　　　備考
1　　　　　A1　　　　　　　4　　　 　A　　　　　A/B/C
　　　　　 A1　　　　　　　　　　　　B
　　　　　 A1　　　　　　　　　　　　B
　　　　　 A1　　　　　　　　　　　　C
2　　　　　A2　　　　　　　1　　　　 A　　　　 A
3　　　　　A3　　　　　　　　　　　　B　　　　B

よろしくお願いします。

回答No.1

pkh4989 · ベストアンサー

こんにちは。
以下のマクロで試してみてください。

Sub 備考編集()
　　Dim wR　　　　　As Long
　　Dim mR　　　　　As Long
　　Dim tCOL()　　　As Variant
　　Dim cHIN　　　　As String
　　Dim wSeq　　　　As Integer
　　Dim wStr　　　　As String
　　Dim wI　　　　　As Integer
　　Dim sR　　　　　As Long
　　'
　　With ActiveSheet
　　　　mR = .Range("B" & Rows.Count).End(xlUp).Row
　　　　cHIN = .Cells(2, 2)　　 '←初期値設定(品番)
　　　　sR = 2　　　　　　　　　'←初期値設定(行)
　　　　For wR = 2 To mR
　　　　　　If .Cells(wR, 2) <> cHIN Then
　　　　　　　　'備考設定
　　　　　　　　wStr = ""
　　　　　　　　For wI = 1 To wSeq
　　　　　　　　　　If wI = 1 Then
　　　　　　　　　　　　wStr = tCOL(wI)
　　　　　　　　　　Else
　　　　　　　　　　　　wStr = wStr & "/" & tCOL(wI)
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　.Cells(sR, "E") = wStr
　　　　　　　　cHIN = .Cells(wR, "B")
　　　　　　　　sR = wR
　　　　　　　　Erase tCOL:　wSeq = 0
　　　　　　End If
　　　　　　'
　　　　　　'同一色存在チェック
　　　　　　If Chk_COL(tCOL, wSeq, .Cells(wR, "D")) = False Then
　　　　　　　　'色設定
　　　　　　　　wSeq = wSeq + 1
　　　　　　　　ReDim Preserve tCOL(wSeq)
　　　　　　　　tCOL(wSeq) = .Cells(wR, "D")
　　　　　　End If
　　　　Next
　　　　'
　　　　If wSeq > 0 Then
　　　　　　'最終備考設定
　　　　　　wStr = ""
　　　　　　For wI = 1 To wSeq
　　　　　　　　If wI = 1 Then
　　　　　　　　　　wStr = tCOL(wI)
　　　　　　　　Else
　　　　　　　　　　wStr = wStr & "/" & tCOL(wI)
　　　　　　　　End If
　　　　　　Next
　　　　　　.Cells(sR, "E") = wStr
　　　　End If
　　End With
End Sub

'同一色存在チェック
Function Chk_COL(tCOL() As Variant, wSeq As Integer, wCD As String) As Boolean
　　Dim wI　　　　　As Integer
　　Chk_COL = False
　　For wI = 1 To wSeq
　　　　If tCOL(wI) = wCD Then
　　　　　　Chk_COL = True
　　　　　　Exit For
　　　　End If
　　Next
End Function

お礼

こんなに早く回答していただいてありがとうございました。次に進めることができました。

回答No.3

n-jun

ANo.2です。
ちょっとミスがありましたので修正版。

Sub　test_2()
　Dim　i　As　Long,　j　As　Long
　Dim　st　As　String
　j　=　0
　For　i　=　2　To　Cells(Rows.Count,　2).End(xlUp).Row　+　1
　　　　　j　=　IIf(j　=　0,　i,　j)
　　　　　If　Range("B"　&　i).Value　=　Range("B"　&　i　+　1).Value　Then
　　　　　　　　st　=　IIf(InStr(st,　Range("D"　&　i).Value)　=　0,　st　&　Range("D"　&　i).Value　&　"/",　st)
　　　　　Else
　　　　　　　　st　=　IIf(InStr(st,　Range("D"　&　i).Value)　=　0,　st　&　Range("D"　&　i).Value　&　"/",　st)
　　　　　　　　Range("E"　&　j).Value　=　Left(st,　Len(st)　-　1)
　　　　　　　　st　=　"":　j　=　0
　　　　　End　If
　Next
End　Sub

お礼

思ったことができました。とても助かりました。ありがとうございました。

回答No.2

n-jun

Sub　test()
　Dim　i　As　Long,　j　As　Long
　Dim　st　As　String
　j　=　0
　For　i　=　2　To　Cells(Rows.Count,　2).End(xlUp).Row　+　1
　　　　　If　j　=　0　Then　j　=　i
　　　　　If　Range("B"　&　i).Value　=　Range("B"　&　i　+　1).Value　Then
　　　　　　　　If　InStr(st,　Range("D"　&　i).Value)　=　0　Then
　　　　　　　　　　　st　=　st　&　Range("D"　&　i).Value　&　"/"
　　　　　　　　End　If
　　　　　Else
　　　　　　　　st　=　st　&　Range("D"　&　i).Value　&　"/"
　　　　　　　　Range("E"　&　j).Value　=　Left(st,　Len(st)　-　1)
　　　　　　　　st　=　"":　j　=　0
　　　　　End　If
　Next
End　Sub
こうゆう感じの事でしょうか。