Combining duplicate rows into one

  • Thread starter Thread starter w0wzers
  • Start date Start date
W

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
 
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
 
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
 
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.
 
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
Click to expand...
'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
 
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
 
Back
Top