Makro: Kopier fra celle, til slutning af række og sæt ind i slutning af række ovenover

Sub Flyt()
Dim rHjem As Range
Dim rFra As Range
Dim rTil As Range

On Error GoTo Fejl

'Hvis cellen til højre for udgangscellen er tom
If IsEmpty(ActiveCell.Offset(0, 1)) Then
  MsgBox "Ingen data at flytte"
  GoTo Slut
End If

'rHjem sættes = udgangscellen
Set rHjem = ActiveCell

'rFra sættes = cellen til højre
Set rFra = rHjem.Offset(0, 1)

'Hvis cellen to kolonner fra udgangscellen
'har et indhold, udvides rFra til sidste
'celle med indhold mod højre.
If Len(rFra.Offset(0, 1).Value) > 0 Then
  Set rFra = Range(rFra, rFra.End(xlToRight))
End If

'rTil sættes = cellen over udgangscellen
Set rTil = rHjem.Offset(-1, 0)

'Hvis denne har et indhold
If Len(rTil.Value) > 0 Then
  'Hvis cellen til højre herfor har et
  'indhold, findes sidste celle mod højre
  'med indhold.
  If Len(rTil.Offset(0, 1).Value) > 0 Then
      'rTil sættes til denne celle
      Set rTil = rTil.End(xlToRight)
      'Hvis det er arkets sidste kolonne
      If rTil.Column <> Columns.Count Then
        MsgBox "Der er ikke plads til at sætte ind"
        GoTo Slut
      Else
        'Ellers sætte rTil til cellen til højre
        Set rTil = rTil.Offset(0, 1)
      End If
  Else
      Set rTil = rTil.Offset(0, 1)
  End If
Else
  'Hvis cellen over udgangscellen er tom
  'søges først mod højre efter en celle
  'med indhold.
  Set rTil = rTil.End(xlToRight)
  'Hvis der er en celle med indhold, og det ikke er
  'sidste kolonne, sættes rTil = cellen til højre.
  If Len(rTil.Value) > 0 And rTil.Column < Columns.Count Then
      Set rTil = rTil.Offset(0, 1)
  Else
      'Ellers sættes rTil = første celle til vanstre
      'med indhold. Hvis der er en celle med indhold,
      'sættes rTil = cellen til højre herfor.
      'Har den ikke et indhold, er vi havnet i kolonne A.
      Set rTil = rTil.End(xlToLeft)
      If Len(rTil.Value) > 0 Then Set rTil = rTil.Offset(0, 1)
  End If
End If

'Data flyttes
rFra.Cut rTil
'Udgangscellen aktiveres
rHjem.Activate

Slut:
Set rHjem = Nothing
Set rFra = Nothing
Set rTil = Nothing
Exit Sub
Fejl:
MsgBox Err.Description & " Procedure Flyt"
Resume Slut
End Sub

  'Hvis der er en celle med indhold, og det ikke er
  'sidste kolonne, sættes rTil = cellen til højre.
  If Len(rTil.Value) > 0 And rTil.Column < Columns.Count Then
      Set rTil = rTil.Offset(0, 1)

  'Hvis der er en celle med indhold, og det ikke er
  'sidste kolonne, sættes rTil = cellen til højre.
  If Len(rTil.Value) > 0 And rTil.Column < Columns.Count Then
      If Len(rTil.Offset(0, 1).Value) > 0 Then
        Set rTil = rTil.End(xlToRight).Offset(0, 1)
      Else
        Set rTil = rTil.Offset(0, 1)
      End If