farhan11941234
New Member
- Joined
- Dec 14, 2019
- Messages
- 29
- Office Version
- 365
- Platform
- Windows
Book1 | |||||
---|---|---|---|---|---|
A | B | C | |||
1 | ID # | Product | Combine Products | ||
2 | 100001 | A | A+B | ||
3 | 100002 | A | A+B+C | ||
4 | 100003 | A | A+B+C+D | ||
5 | 100004 | A | A+B | ||
6 | 100005 | A | A | ||
7 | 100006 | B | B | ||
8 | 100007 | C | C | ||
Sheet1 (2) |
Book1 | ||||
---|---|---|---|---|
A | B | |||
1 | ID # | Product | ||
2 | 100008 | E | ||
3 | 100008 | D | ||
4 | 100003 | D | ||
5 | 100008 | C | ||
6 | 100007 | C | ||
7 | 100003 | C | ||
8 | 100002 | C | ||
9 | 100008 | B | ||
10 | 100006 | B | ||
11 | 100004 | B | ||
12 | 100003 | B | ||
13 | 100002 | B | ||
14 | 100001 | B | ||
15 | 100008 | A | ||
16 | 100005 | A | ||
17 | 100004 | A | ||
18 | 100003 | A | ||
19 | 100002 | A | ||
20 | 100001 | A | ||
Sheet1 |
Sub farhan11941234()
Application.ScreenUpdating = False
Dim ws As Worksheet, Cel As Range, Rng As Range, Prod As Range, F As Long, Addr As String
Dim MainStr As String, ProdStr As String
'copy to new sheet and remove duplicates
ActiveSheet.Copy Before:=Sheets(1)
Set ws = Sheets(1)
ws.Cells(1, 3) = "Combine Products"
ws.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
'sort data by ID and then by Product
With ws.Sort
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SortFields.Add Key:=Range("B1"), Order:=xlAscending
.SetRange Range("A:B")
.Header = xlYes
.Apply
End With
'concatenate strings
Set Rng = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
For Each Cel In Rng
ProdStr = Cel.Offset(, 1)
If WorksheetFunction.CountIf(ws.Range("A2", Cel), Cel) = 1 Then
MainStr = ProdStr
Set Prod = Cel.Offset(, 2)
Else
MainStr = MainStr & "+" & ProdStr
End If
If Cel.Offset(1) <> Cel Then Prod = MainStr
Next Cel
'remove unwnated rows
Set Prod = ws.Cells(ws.Rows.Count, 3)
For Each Cel In Rng.Offset(, 2)
If Cel = "" Then Set Prod = Union(Prod, Cel)
Next Cel
Prod.EntireRow.Delete
End Sub