Find Duplicates and Append

[HUBBUB88]

Hi one and all

Want to do a look for duplicate and if yes then append data.

Example

Column 1 Column 2
1234 product1
1234 product 2
1234 product 3

i would like it find where column 1 contains a duplicate then if yes
append the data or copy it into column 2, and 3 and 4

Column 1 Column 2 Column 3 Column 4
1234 product1 product 2 product 3
1234 product 2
1234 product 3


Possible?


Thanks

If possible also to mark in column 5 as a dup like this


Column 1 Column 2 Column 3 Column 4 Column 5
1234 product1 product 2 product 3
1234 product 2 Dup
1234 product 3 Dup

 

[STEVE BELL]

There are many ways - a simplistic approach is to cycle through the cells
(this may be a little cludgey, but it should work.)

This code only works if list is sorted by column A

Dim lrw as long, x as long, y as long, z as long, cel as range

' find last row in column A
lrw = Cells(Rows.Count,"A").End(xlUp).Select

' loop through all cells in column A
For x = lrw to 1 step -1
' check for duplicates y > 1 means duplicates
y = worksheetfunction.Countif(Range("A1:A" & x)

' if duplicates, and duplicates haven't been processed
' transfer each duplicate to next column on row with first entry.
If y > 1 And len(cells(x-y + 1,3) = 0 then
for z = 2 to y
cells(x-y +1,z + 1) = cells(x - y + z , z + 1)
next
End if
Next

This is untested but should work...
Double check by trying it on a copy of your workbook.
Step through some of the code to make sure I got my math straight.

 

[DKY]

I'm fumbling through this thinking maybe it will help me in what I'm
trying to accomplish but for some reason the following lines are red in
my VB Editor

y = worksheetfunction.Countif(Range("A1:A" & x)

If y > 1 And len(cells(x-y + 1,3) = 0 then

Any ideas?