This is close but I only want it to merge Column A and this seems to delete extra cells not merge them.
Dim MY_ROWS As Long
Dim MY_LINK As String
Application.ScreenUpdating = False
Range("A1").Resize(Range("A65536").End(xlUp).Row, Range("IV16").End(xlToLeft).Column).Borders.LineStyle = xlContinuous
For MY_ROWS = Range("A65536").End(xlUp).Row To 2 Step -1
If Range("B" & MY_ROWS).Value = Range("B" & MY_ROWS - 1).Value Then
Range("A" & MY_ROWS & ":C" & MY_ROWS).ClearContents
End If
Next MY_ROWS
For MY_ROWS = Range("D65536").End(xlUp).Row To 17 Step -1
If Range("A" & MY_ROWS).Value = "" Then
Range(Range("A" & MY_ROWS), Range("A" & MY_ROWS).End(xlUp)).Select
Range(Range("A" & MY_ROWS), Range("A" & MY_ROWS).End(xlUp)).MergeCells = True
Range(Range("B" & MY_ROWS), Range("B" & MY_ROWS).End(xlUp)).MergeCells = True
Range(Range("C" & MY_ROWS), Range("C" & MY_ROWS).End(xlUp)).MergeCells = True
MY_ROWS = MY_ROWS - Selection.Cells.Count + 1
End If
Next MY_ROWS
For MY_ROWS = 17 To Range("D65536").End(xlUp).Row
MY_LINK = Range("D" & MY_ROWS).Value
ActiveSheet.Hyperlinks.Add Anchor:=Range("D" & MY_ROWS), Address:= _
MY_LINK, TextToDisplay:=Range("D" & MY_ROWS).Value
Next MY_ROWS
With Range("A17:D" & Range("D65536").End(xlUp).Row)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = False