Combining duplicate rows into one

[w0wzers]

I found this macro
Option Explicit
Sub testme()

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long

Set wks = ActiveSheet
With wks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value
Then
.Range(.Cells(iRow, "B"), _
.Cells(iRow,
..Columns.Count).End(xlToLeft)).Copy _
Destination:=.Cells(iRow - 1, .Columns.Count) _
.End(xlToLeft).Offset(0, 1)

.Rows(iRow).Delete
End If
Next iRow
End With
End Sub

which combines the duplicate rows but adds the duplicate data into new
columns
I need it to add the data to the existing columns
the code right now does:
ex. Column A|Column B|Column C|Column D
1 Book Dog Pen
1 Bag Cat Pencil
After the macro:
Column A|Column B|Column C|Column D|Column E|Column F|Column G|
1 Book Dog Pen Bag
Cat Pencil

I need it to be:
Column A|Column B|Column C|Column D
1 Book,Bag| Dog,Cat| Pen,Pencil


Can any help? Please I have like 17000 records i need this for
Thank to all, Especially Dave Peterson for writing that macro

 

[Dave Peterson]

Maybe you can modify this:

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Long

Set wks = ActiveSheet
With wks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
For iCol = 2 To _
.Cells(iRow, .Columns.Count).End(xlToLeft).Column
If .Cells(iRow, iCol).Value = "" Then
'skip it
Else
.Cells(iRow - 1, iCol).Value _
= .Cells(iRow - 1, iCol).Value & _
"," & .Cells(iRow, iCol).Value
End If
Next iCol
.Rows(iRow).Delete
End If
Next iRow
End With
End Sub

 

[Don Guillett]

This seems to work and could probably be even more efficient but left as is
so you can understand what is happening. Assumes numbers in col a and 3
columns of data

Sub puttogether()

For i = 1 To 3
s1 = ""
s2 = ""
s3 = ""
With Worksheets("sheet7").Range("a1:a500")
Set c = .Find(i)
If Not c Is Nothing Then
firstAddress = c.Address
Do
s1 = s1 & "," & c.Offset(, 1)
s2 = s2 & "," & c.Offset(, 2)
s3 = s3 & "," & c.Offset(, 3)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
If Len(s1) > 0 Then c.Offset(, 4) = Right(s1, Len(s1) - 1)
If Len(s2) > 0 Then c.Offset(, 5) = Right(s2, Len(s2) - 1)
If Len(s3) > 0 Then c.Offset(, 6) = Right(s1, Len(s3) - 1)
Next i
End Sub

 

[Don Guillett]

chg
For i = 1 To 3
to
For i = 1 To Application.Max(Columns("a:a"))

 

[w0wzers]

Thanks Guys. Dave yours worked great. Don yours gave me a memory error.
There is one more thing now. now if there was duplicate text in other
columns I have this:
Column C
"Between";"Between";"Between";"Between";"Between";"Between";"Between"

Is there any way for it to only to paste unique text?


ex. Column A|Column B|Column C|Column D
1 Book Dog Pen
1 Book Cat Pen
would become

ex. Column A|Column B|Column C|Column D
1 Book Dog, Cat Pen



Thanks for all your help once again.

 

[Dave Peterson]

Try this against a copy of your data:

Option Explicit
Sub testme()

Dim wks As Worksheet

Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Long

Set wks = ActiveSheet
With wks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
For iCol = 2 To _
.Cells(iRow, .Columns.Count).End(xlToLeft).Column
If .Cells(iRow, iCol).Value = "" Then
'skip it
Else
If InStr(1, "," & .Cells(iRow, iCol) & ",", "," _
& .Cells(iRow - 1, iCol) & ",", vbTextCompare) _

0 Then

'it's already there,
'but don't lose the previous concatenation
.Cells(iRow - 1, iCol).Value _
= .Cells(iRow, iCol).Value
Else
.Cells(iRow - 1, iCol).Value _
= .Cells(iRow - 1, iCol).Value & _
"," & .Cells(iRow, iCol).Value
End If
End If
Next iCol
.Rows(iRow).Delete
End If
Next iRow
End With
End Sub

 

[Don Guillett]

I made a mod to the s3 and changed to not add dups in the same column.
Tested fine.
1 dog cat mouse dog,cat cat,dog mouse,pig
9 b2 d2 p2 b2 d2 p2
3 b3 d3 p3 b3,b6 d3,d6 p3,p6
1 cat dog pig
2
3 b6 d6 p6
4 b7 d7 p7 b7 d7 p7
5 b8 d8 p8 b8 d8 p8
6 b9 d9 p9 b9 d9 p9
1 dog cat pig


Sub puttogether()
For i = 1 To Application.Max(Columns("a:a"))
s1 = ""
s2 = ""
s3 = ""
lr = Cells(Rows.Count, "a").End(xlUp).Row
With ActiveSheet.Range("a1:a" & lr)
Set c = .Find(i)
If Not c Is Nothing Then
firstAddress = c.Address
Do
' s1 = s1 & "," & c.Offset(, 1)
' s2 = s2 & "," & c.Offset(, 2)
' s3 = s3 & "," & c.Offset(, 3)
If InStr(s1, c.Offset(, 1)) < 1 Then s1 = s1 & "," & c.Offset(, 1)
If InStr(s2, c.Offset(, 2)) < 1 Then s2 = s2 & "," & c.Offset(, 2)
If InStr(s3, c.Offset(, 3)) < 1 Then s3 = s3 & "," & c.Offset(, 3)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If

End With
If Len(s1) > 0 Then c.Offset(, 4) = Right(s1, Len(s1) - 1)
If Len(s2) > 0 Then c.Offset(, 5) = Right(s2, Len(s2) - 1)
If Len(s3) > 0 Then c.Offset(, 6) = Right(s3, Len(s3) - 1)
Next i
End Sub

Sub separatecell() 'mine better
For Each c In Selection
x = InStr(c, "&")
c.Offset(, 1) = Right(c, Len(c) - x)
c.Value = Left(c, x - 2)
Next c
End Sub

 

[w0wzers]

Thanks for all your help guys. Everything worked perfectly.

 

[Don Guillett]

The archives would like to know your final solution