Sub Remove_Duplicate()

Dim LASTROW As Long
Dim I As Long
Dim J As Long
Dim K As Long
Dim MyVALUE As Variant

Application.ScreenUpdating = False
LASTROW = Range("A" & Rows.Count).End(xlUp).Row
RowCount = 1
Do While Range("A" & RowCount) < ""
Do While Range("A" & RowCount) = Range("A" & (RowCount + 1))
For ColCount = 2 To 5
If Cells(RowCount, ColCount) = "" And Cells(RowCount + 1,
ColCount) < "" Then
Cells(RowCount, ColCount) = Cells(RowCount + 1, ColCount)
End If
Next ColCount
Rows(RowCount + 1).Delete
Loop
RowCount = RowCount + 1
Loop
Application.ScreenUpdating = True
'
End Sub
"JakeShipley2008" wrote:

I am trying to merge data in several columns to one row, for example.

Col 'A' Col 'B' Col 'C' Col 'D' Col 'E'
Joe 10/1/08
Joe 10/2/08
Joe 10/3/08
Kim 10/2/08
Kim 10/1/08
John 10/1/08
John 10/2/08
John 10/3/08
John 10/4/08

The Output should look like this:

Col 'A' Col 'B' Col 'C' Col 'D' Col 'E'
Joe 10/1/08 10/2/08 10/3/08

Kim 10/1/08 10/2/08
John 10/1/08 10/2/08 10/3/08 10/4/08


I have the following macro but it does not seem to work completely right. It
does some merging but leaves some duplicate names - wondered if anyone could
help?

Sub Remove_Duplicate()

Dim LASTROW As Long
Dim I As Long
Dim J As Long
Dim K As Long
Dim MyVALUE As Variant

Application.ScreenUpdating = False
LASTROW = Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To LASTROW - 1
MyVALUE = Cells(I, "C") & Cells(I, "D")
For J = I + 1 To LASTROW
If (MyVALUE = Cells(J, "D") & Cells(J, "E")) Then
For K = 1 To 13
If (Cells(I, K) = "") Then Cells(I, K) = Cells(J, K)
Next K
Cells(J, "A").EntireRow.Delete
End If
Next J
Next I
Application.ScreenUpdating = True
'
End Sub
--
Jake