Solved: Combine Data into one Cell

[bdsii]

Hello all....I am attaching a sample spreadsheet with the test data and desired output for your review.

I have two columns, PN and Manuf. If the PN in row 2 is equal to the PN in row 3, I would like to combine the contents of the Manuf cell row2 with the contents of the Manuf cell row3 and put this data into a third column called Combined on row 2. I would then like to delete all rows with the Duplicate PNs.

The result would be unique PNs and the Combined column would have combined Manuf data if there were duplicate PNs.

This is hard to explain but I think from the attachment, you can see what I am trying to accomplish. I cannot figure out how to combine data into one cell.

Any help you can provide would be appreciated.

thanks!

[georgiboy]

If you delete the row where you have placed the word "Data", thus making the true date start in row(2) then this will work...
Sub Combine()
Dim EndRow As Long, x As Long

EndRow = Range("A" & Rows.Count).End(xlUp).Row

'combine loop
For x = 2 To EndRow
If Range("A" & x).Value = Range("A" & x + 1).Value Then
Range("C" & x).Value = Range("B" & x).Value & ";" & Range("B" & x + 1).Value
Else
Range("C" & x).Value = Range("B" & x).Value
End If
Next x

'delete loop
For x = EndRow To 2 Step -1
If WorksheetFunction.CountIf(Range("A:A"), Range("A" & x).Value) > 1 Then
Rows(x).Delete
End If
Next x

End Sub

You may like to make this more reliable by adding sheet names and so on but this should put you on track.

Hope this helps.

[bdsii]

THANKS georgiboy !! That worked great.

I realized that I did not state in my text or show in my example that there could be instances where PN is duplicated a variable number of times and the Manuf should be combined together into one cell. My example only showed 2 PNs being equal.

I have edited my example spreadsheet to show instances where a PN is listed more than twice and how the data should look afterward.

I tried editing your Macro but got hung up on how to combine the data and then deleting rows but the one where the combined data exists.

Can you show me how to account for this scenario where there could be many PNs that equal and having to combine the Manuf for each one into one cell and then delete the extras ?

thanks so MUCH!!

[georgiboy]

There is probably a better way to do this but this is what i come up with, it will work even if the duplicates are not underneath each other...
Sub CombFind()
Dim EndRow As Long, rCell As Range, x As Long
Dim CombVal As String, FirstVal As String

EndRow = Range("A" & Rows.Count).End(xlUp).Row

'find and combine loop
For Each rCell In Range("A2:A" & EndRow).Cells
FirstVal = rCell.Offset(, 1).Value & ";"
For x = 1 To Application.CountIf(Range("A:A"), rCell.Value) - 1
CombVal = CombVal & Range("A2:A" & EndRow).Find(rCell.Value, rCell.Offset(x - 1, 0)).Offset(, 1).Value & ";"
Range("A2:A" & EndRow).Find(rCell.Value, rCell).ClearContents
Next x
rCell.Offset(, 2).Value = Left(FirstVal & CombVal, Len(FirstVal & CombVal) - 1)
CombVal = ""
Next rCell

'delete loop
For x = EndRow To 2 Step -1
If Range("A" & x).Value = "" Then
Range("A" & x & ":C" & x).Delete xlUp
End If
Next x

End Sub
Hope this helps

[bdsii]

You are da MAN, georgiboy !!! Thanks so much for your help, would not have cracked that without your help! :clap2:

I am marking this thread solved and will be sending you email if it works correctly.

I really appreciate it!

[georgiboy]

This might help...
Sub CombFind()
Dim EndRow As Long, rCell As Range, x As Long
Dim CombVal As String, FirstVal As String

EndRow = Range("A" & Rows.Count).End(xlUp).Row 'defines the last row with data in your data range (lookinng at column "A")

For Each rCell In Range("A2:A" & EndRow).Cells 'find and combine (for next loop), defined by EndRow above
FirstVal = rCell.Offset(, 1).Value & ";" 'this makes sure it takes the first value even if no duplicates are found

'second for next loop defined by how many duplicates are found minus the one taken already in FirstVal
For x = 1 To Application.CountIf(Range("A:A"), rCell.Value) - 1
'puts together a string of data seperated by ";" by using the find below, offsets the find after part to catch_
'new duplicates each time
CombVal = CombVal & Range("A2:A" & EndRow).Find(rCell.Value, rCell.Offset(x - 1, 0)).Offset(, 1).Value & ";"
'clears the found cell to make available to the delete loop
Range("A2:A" & EndRow).Find(rCell.Value, rCell).ClearContents
Next x 'end of second for next loop
'combines FirstVal with the found duplicates (CombVal) and takes the extra ";" off the end using the left and len functions
rCell.Offset(, 2).Value = Left(FirstVal & CombVal, Len(FirstVal & CombVal) - 1)
CombVal = "" 'resets CombVal to nothing
Next rCell 'end of for next loop

'delete loop, starts at the bottom of the data and loops up (hence step -1)
For x = EndRow To 2 Step -1
If Range("A" & x).Value = "" Then 'finds an empty cell in column "A"
Range("A" & x & ":C" & x).Delete xlUp 'deletes range required
End If
Next x 'end of loop

End Sub