Merging Rows

[JakeShipley2008]

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

 

[Joel]

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

 

[Dave Peterson]

When you're deleting rows like this, it really makes it easier to start at the
bottom and work your way to the top. Then you don't have to worry about what
row you're code is processing.

Option Explicit
Sub Remove_Duplicate()

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

Set wks = Worksheets("Sheet1")

Application.ScreenUpdating = False

With wks
TopRow = 2 'headers in row 1
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

For iRow = LastRow To TopRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
'same name
For iCol = .Cells(iRow, .Columns.Count).End(xlToLeft).Column _
To 2 Step -1
If IsEmpty(.Cells(iRow, iCol).Value) Then
'do nothing
Else
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
End If
Next iCol
.Rows(iRow).Delete
End If
Next iRow
End With

Application.ScreenUpdating = True

End Sub

This does expect that there is no more than one date per person per column.