if cell not empty, append to bottom of another cell along with specific columns on same row

[johnmerlino]

Hey all,

In instances of hundreds of thousands of records, is there an automated way, such as an excel formula, to take contents of a cell if not empty and extract only it from the cell but append it and city, state, and zip cells on same row to bottom of list of records?

For example, let's say this is my list:

+------+------+-------------+------------+
| A      | B      | C             | D                    |
+------+------+------+--------------------+
| Ann   |         |  540 Road |   Oakland Park   | 
+------+------+------+--------------------+
| Ann   | Bill    |   333 Street |   Oakland Park | 
+------+------+------+--------------------+

Since the second row in the set above contains content, I would like it to appear like this:

+------+------+-------------+------------+
| A      | B      | C             | D                    |
+------+------+------+--------------------+
| Ann   |         |  540 Road |   Oakland Park   | 
+------+------+------+--------------------+
| Ann   |         |   333 Street |   Oakland Park | 
+------+------+------+--------------------+
| Bill     |         |   333 Street |   Oakland Park | 
 +------+------+------+--------------------+

The thing is there could be thousands of records with content in cell B and so it would be too tedious to copy and paste. Is there a solution to this problem?

Thanks for response.

 

[Misca]

Maybe something like this:

Sub CopyToNewRows()

Dim c As Range
Dim Rng As Range
Dim NewRecord As Range

Application.ScreenUpdating = False

Set Rng = Range("B:B").SpecialCells(xlConstants)
Set NewRecord = Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

If Not Rng Is Nothing Then  'Skip the macro if column B is empty

    For Each c In Rng
        If c.Row > 1 Then
            c.EntireRow.Copy Destination:=NewRecord 'Copies the entire row to the bottom of the records
                With NewRecord
                    .Value = .Offset(0, 1).Value  'Writes the Column B value to Column A on the last row of data
                    .Offset(0, 1).Value = ""   'Empties the Column B value
                End With
            c.Value = ""        'Empties the column B value
            
            Set NewRecord = NewRecord.Offset(1, 0)
        End If
    Next c

End If

End Sub

Paste the code above to a module and run the macro.

If you're not sure how to do this, watch the video "Copy Excel VBA Code to a Regular Module" at http://www.contextures.com/xlVideos04.html#CopyCode

 

[johnmerlino]

Thanks for that. I tested and it worked for situation I defined.

 

[johnmerlino]

Thanks for macro. Problem is with 800,000 records, this goes on for several hours until I am forced to force quit excel. Any other alternatives?