VBA / Macros for combining multiple cell ranges based on adjacent cell values

[chaitu585]

I've a range of text with details such as Name, Email ID, Telephone and Address.

I want the all the address lines to be combined into once cell separated by line breaks as given below

I've been using "kutools for excel" combine rows option for these kind of functionality and it is okay for one or two entries. However, here I have hundreds of these address bars and I'd really appreacite if some one could put together a VBA code for this (I've no idea how to write one).

As far as i think, ideal logic to run a loop would be; based on the cell values in column one,

if a cell is filled combine all rows below that (until you can find another filled cell in the column) to the top row. i.e

A1 is filled. Next Filled is A2. so leave row 1.
A2 is filled. Next Filled is A4. So combine rows 2 and 3.
A4 is filled. Next Filled is A6. So combine rows 4 and 5.
A6 is filled. Next filled is A10. So combine rows 6,7,8 and 9.
A10 is filled. Next Filled is A11. so leave row 10
.
.
.
and so on. We can run this loop till a certain row number.

If someone could put this logic into a code, i would be much obliged.

Thanks in Advance.

 

[wideboydixon]

Please run this on a copy of the data. Note the constant at the top; change that as necessary.

Private Const LASTRECORDROWTEXT = "Address:"
Public Sub CombineRecords()

Dim lastRow As Long
Dim thisRow As Long

Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
thisRow = 2
Do While thisRow <= lastRow
    If IsEmpty(Cells(thisRow, "A").Value) And IsEmpty(Cells(thisRow, "B").Value) Then
        If Left(Cells(thisRow - 1, "A").Value, Len(LASTRECORDROWTEXT)) = LASTRECORDROWTEXT Then
            thisRow = thisRow + 1
        Else
            Cells(thisRow, "A").EntireRow.Delete
            lastRow = lastRow - 1
        End If
    Else
        If IsEmpty(Cells(thisRow, "A").Value) Then
            Cells(thisRow - 1, "B").Value = Cells(thisRow - 1, "B").Value & vbCrLf & Cells(thisRow, "B").Value
            Cells(thisRow, "A").EntireRow.Delete
            lastRow = lastRow - 1
        Else
            thisRow = thisRow + 1
        End If
    End If
Loop
Application.ScreenUpdating = True

End Sub

WBD

 

[chaitu585]

It works like a charm. Really thanks!