Need Macro to Repeat Until Finished (at Blank cells)

[ACP454]

Hello and thanks in advance for your help,

I have a database of roughly 5,000 companies with 20,000 lines of data, with the company data stacked vertically vs horizontally. Each company is shown as follows...

• Company name
• Street address
• City, St Zip
• County

I need each company's data to appear on one row and I have successfully created the following macro to move the cell contents, after I insert three empty columns, to the right of the original data cells, as follows....
__________________________________________
Sub NameMove()
'
' NameMove Macro
'
' Keyboard Shortcut: Ctrl+n
'
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.Cut Destination:=ActiveCell.Offset(-3, 3).Range("A1")
ActiveCell.Offset(1, 0).Range("A1").Select

End Sub
_________________________________________

My question is, what is the code to have this process repeat until there are no more cells with data?

THANK YOU for your help!

ACP454

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub test1()
   Dim i As Long
   For i = 1 To 20 Step 4
      Cells(i, 2).Resize(, 3).Value = Application.Transpose(Cells(i + 1, 1).Resize(3))
   Next i
  [COLOR=#0000ff] Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete[/COLOR]
End Sub

If you don't want to delete the blank rows remove the line in blue

 

[ACP454]

Hi Fluff,

Will give this a shot. Appreciated.

ACP454