How to arrange cells like this?

[Kenneth Hobson]

Place code in a Module. Run for active sheet. Be sure to run on a backup copy as usual when testing copy.

Sub MoveRowsUp()
  Dim r As Range, r1 As Range, r2 As Range, v, i As Long
  
  Set r = Range("A1", Range("A1").End(xlDown).Offset(1))
  
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  
  On Error GoTo EndSub
  For i = r.Rows.Count To 1 Step -1
    Set r1 = Cells(i, "A")
    Set r2 = Cells(i - 1, "A")
    If r1.Value = "" And r2.Value > 0 Then
      'Concatenate column B values
      v = r2.Offset(, 1).Value & r1.Offset(, 1).Value
      Range("B" & i & ":F" & i).Cut Destination:=Range("B" & i - 1 & ":F" & i)
      Rows(i).Delete Shift:=xlUp
      Cells(i - 1, "B").Value = v 'Add concatenated column B value back.
    End If
  Next i
  
EndSub:
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub