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

chaitu585

New Member
Joined
Feb 19, 2018
Messages
3
I've a range of text with details such as Name, Email ID, Telephone and Address.

fMhg86Y.png


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

xrt5Qt6.png


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.
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Please run this on a copy of the data. Note the constant at the top; change that as necessary.

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,113,998
Members
448,539
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top