Sub rivilisäys()
  Dim r
  r = 1
  Do While Cells(r, 1) <> ""
    Rows(r + 1).Insert
    Cells(r, 2).Cut Cells(r + 1, 1)
    r = r + 2
  Loop
End Sub