Excel macro cut/paste/delete do loop

Wanting to create a Excel 2007 macro that loops, or auto repeats until it runs out of data to copy/paste.  I manually recorded the code below. It works, but depending on the data size (small sample file attached), I might have 1 iteration or 5000 to process.  

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("B4").Select                   'The pattern is Select (the first step will always be B4)
    Selection.Cut                            'Cut
    Range("H3").Select                   'Select  (a cell up 1 and over 6 in this case H3)
    ActiveSheet.Paste                     'Paste  
    Rows("4:5").Select                    'Select  
    Selection.Delete Shift:=xlUp     'Delete
    Range("B5").Select                   'Repeat until there is no data in the next B cell
    Selection.Cut
    Range("H4").Select
    ActiveSheet.Paste
    Rows("5:6").Select
    Selection.Delete Shift:=xlUp
    Range("B6").Select                 'If empty then stop
End Sub
Sample-File.xlsx