Hello:

I think I have a solution for you, try the following code on a sample
of your data. Please remember, there is no undo history for Macros so
test it first before using it on your final data.

Let me know if you have any questions. To delete the records, simply
remove ".Select" at the end. Watch for unintentional line breaks when
copying code.


Steven


Sub CombineRows()
Dim WS As Worksheet ' Worksheet containing data
Dim Rng1 As Range ' Record range
Dim MyCell As Range ' Range Variable
Dim R As Long ' Count of blank rows
Dim COffset As Long ' Incrementing Column offset for
merging rows
Dim ROffset As Long ' Incrementing Row offset for merging
rows
Dim LastR As Long ' Last row of data

'Disables screen updating and calculations to speed up macro
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = False
End With

Set WS = ActiveSheet

' Establishes last row of data, using column D
LastR = WS.Cells(Rows.Count, "D").End(xlUp).Row

'**** IF THE FIRST ROW CONTAINS HEADERS, USE THE FOLLOWING LINE AND
REM THE NEXT
' Set Rng1 = WS.Range("A2:A" & LastR)

' Establishes range containing records REM IF HEADER ROW EXISTS
Set Rng1 = WS.Range("A1:A" & LastR)

For Each MyCell In Rng1
R = 0

' If there is any data in column A of row
If MyCell.Value "" Then
' Counts blank rows between records
Do Until MyCell.Offset(R + 1, 0).Value ""
' Exits before it loops beyond last row of data
If MyCell.Offset(R, 0).Address = Cells(LastR + 1, "A").Address
Then Exit Do
R = R + 1
Loop

' Combines row data
For ROffset = 0 To R
For COffset = 0 To 3
MyCell.Offset(0, (ROffset * 3) + COffset + 3).Value = _
MyCell.Offset(ROffset + 1, COffset + 3).Value
Next COffset
Next ROffset
End If
Next MyCell

'Filters and deletes blank rows
Rng1.AutoFilter Field:=1, Criteria1:="="
Rng1.Offset(1, 0).EntireRow.SpecialCells(xlCellTypeVisible).Selec t
'Delete 'Remove select to delete rows

' Restores screen updating and calculations
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = True
End With
End Sub