Sub merge()
Dim iRow As Long
Dim LRow As Long 'Last data filled row
Dim CWS As Worksheet
Dim AWS As Worksheet
Dim oRow As Long
Dim duh As Integer
Set AWS = ActiveSheet
Set CWS = Worksheets.Add(after:=ActiveSheet)
CWS.Name = "Combined"
AWS.Activate
LRow = Cells(Rows.Count, "A").End(xlUp).Row
oRow = 1
'copy header row to Combined sheet
Range("A1:V1").Copy Destination:=CWS.Range("A1:V1")
For iRow = 2 To LRow
If Cells(iRow, "A") <> Cells(iRow - 1, "A") Then
'New Contact ID: copy entire row
oRow = oRow + 1
Range(Cells(iRow, "A"), Cells(iRow, "V")).Copy _
Destination:=CWS.Cells(oRow, "A")
Else
'Same as previous contact row: add to previous row's data
If Cells(iRow, "B") = Cells(iRow - 1, "B") Then
duh = 1
Else
CWS.Cells(oRow, "B") = CWS.Cells(oRow, "B") & vbLf & Cells(iRow, "B")
End If
If Cells(iRow, "C") = Cells(iRow - 1, "C") Then
duh = 1
Else
CWS.Cells(oRow, "C") = CWS.Cells(oRow, "C") & vbLf & Cells(iRow, "C").Text
End If
If Cells(iRow, "D") = Cells(iRow - 1, "D") Then
duh = 1
Else
CWS.Cells(oRow, "D") = CWS.Cells(oRow, "D") & vbLf & Cells(iRow, "D").Text
End If
If Cells(iRow, "E") = Cells(iRow - 1, "E") Then
duh = 1
Else
CWS.Cells(oRow, "E") = CWS.Cells(oRow, "E") & vbLf & Cells(iRow, "E").Text
End If
If Cells(iRow, "F") = Cells(iRow - 1, "F") Then
duh = 1
Else
CWS.Cells(oRow, "F") = CWS.Cells(oRow, "F") & vbLf & Cells(iRow, "F")
End If
If Cells(iRow, "G") = Cells(iRow - 1, "G") Then
duh = 1
Else
CWS.Cells(oRow, "G") = CWS.Cells(oRow, "G") & vbLf & Cells(iRow, "G")
End If
If Cells(iRow, "H") = Cells(iRow - 1, "H") Then
duh = 1
Else
CWS.Cells(oRow, "H") = CWS.Cells(oRow, "H") & vbLf & Cells(iRow, "H")
End If
If Cells(iRow, "I") = Cells(iRow - 1, "I") Then
duh = 1
Else
CWS.Cells(oRow, "I") = CWS.Cells(oRow, "I") & vbLf & Cells(iRow, "I")
End If
If Cells(iRow, "J") = Cells(iRow - 1, "J") Then
duh = 1
Else
CWS.Cells(oRow, "J") = CWS.Cells(oRow, "J") & vbLf & Cells(iRow, "J")
End If
If Cells(iRow, "K") = Cells(iRow - 1, "K") Then
duh = 1
Else
CWS.Cells(oRow, "K") = CWS.Cells(oRow, "K") & vbLf & Cells(iRow, "K")
End If
If Cells(iRow, "L") = Cells(iRow - 1, "L") Then
duh = 1
Else
CWS.Cells(oRow, "L") = CWS.Cells(oRow, "L") & vbLf & Cells(iRow, "L")
End If
If Cells(iRow, "M") = Cells(iRow - 1, "M") Then
duh = 1
Else
CWS.Cells(oRow, "M") = CWS.Cells(oRow, "M") & vbLf & Cells(iRow, "M")
End If
If Cells(iRow, "N") = Cells(iRow - 1, "N") Then
duh = 1
Else
CWS.Cells(oRow, "N") = CWS.Cells(oRow, "N") & vbLf & Cells(iRow, "N")
End If
If Cells(iRow, "O") = Cells(iRow - 1, "O") Then
duh = 1
Else
CWS.Cells(oRow, "O") = CWS.Cells(oRow, "O") & vbLf & Cells(iRow, "O")
End If
If Cells(iRow, "P") = Cells(iRow - 1, "P") Then
duh = 1
Else
CWS.Cells(oRow, "P") = CWS.Cells(oRow, "P") & vbLf & Cells(iRow, "P")
End If
If Cells(iRow, "Q") = Cells(iRow - 1, "Q") Then
duh = 1
Else
CWS.Cells(oRow, "Q") = CWS.Cells(oRow, "Q") & vbLf & Cells(iRow, "Q")
End If
If Cells(iRow, "R") = Cells(iRow - 1, "R") Then
duh = 1
Else
CWS.Cells(oRow, "R") = CWS.Cells(oRow, "R") & vbLf & Cells(iRow, "R")
End If
If Cells(iRow, "S") = Cells(iRow - 1, "S") Then
duh = 1
Else
CWS.Cells(oRow, "S") = CWS.Cells(oRow, "S") & vbLf & Cells(iRow, "S")
End If
If Cells(iRow, "T") = Cells(iRow - 1, "T") Then
duh = 1
Else
CWS.Cells(oRow, "T") = CWS.Cells(oRow, "T") & vbLf & Cells(iRow, "T")
End If
If Cells(iRow, "U") = Cells(iRow - 1, "U") Then
duh = 1
Else
CWS.Cells(oRow, "U") = CWS.Cells(oRow, "U") & vbLf & Cells(iRow, "U").Text
End If
If Cells(iRow, "V") = Cells(iRow - 1, "V") Then
duh = 1
Else
CWS.Cells(oRow, "V") = CWS.Cells(oRow, "V") & vbLf & Cells(iRow, "V")
End If
End If
If iRow Mod 100 = 2 Then
Application.StatusBar = "Input Row " & iRow & " -> Output Row " & oRow
End If
Next iRow
Beep
MsgBox iRow & " rows combined into " & oRow & " rows.", vbInformation
CWS.Columns.AutoFit
CWS.Columns("B").ColumnWidth = 16
CWS.Rows.AutoFit
CWS.Rows.VerticalAlignment = xlTop
Application.StatusBar = False
End Sub
The problem is that column C, D, and E are dates and I keep getting ##### as one of the concatenates. I know it is a format issue, but I don't know how to solve it.
Bookmarks