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

(E-Mail Removed) wrote:
>
> 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

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
SalesAid Software
(E-Mail Removed)
<(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
>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
>

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

--
Don Guillett
SalesAid Software
(E-Mail Removed)
"Don Guillett" <(E-Mail Removed)> wrote in message
news:%23Duu$(E-Mail Removed)...
> 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
> SalesAid Software
> (E-Mail Removed)
> <(E-Mail Removed)> wrote in message
> news:(E-Mail Removed)...
>>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
>>
>
>

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
'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

"(E-Mail Removed)" wrote:
>
> 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

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

--
Don Guillett
SalesAid Software
(E-Mail Removed)
<(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> 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.
>

Thanks for all your help guys. Everything worked perfectly.

The archives would like to know your final solution

--
Don Guillett
SalesAid Software
(E-Mail Removed)
<(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> Thanks for all your help guys. Everything worked perfectly.
>