Move Specific Columns up and down

[adam]

Hi anyone,

How can I make the following code to move only columns E:O up and down when a row between row 18:53 in column E is selected.

The Movedown button will move the selected row up the last visible data row between rows 18:53.

Code: Select all

Sub MoveUp()

    Dim arr As Variant
    Dim r1 As Range
    Dim r2 As Range
    
    Set r1 = Selection
    If r1.Row = 18 Then
        MsgBox "Top reached"
    Else
        Set r2 = r1.Offset(-1).Resize(1)
        arr = r2
        r2.Resize(r1.Rows.Count) = r1.Value
        r2.Resize(r1.Rows.Count).Select
        r1.Resize(1).Offset(r1.Rows.Count - 1) = arr
    End If
End Sub

Sub MoveDown()

    Dim arr As Variant
    Dim r1 As Range
    Dim r2 As Range
    
    Set r1 = Selection
    If r1.Row + r1.Rows.Count - 1 = Rows.Count Then
        MsgBox "Bottom reached"
    Else
        Set r2 = r1.Resize(1).Offset(r1.Rows.Count)
        arr = r2
        r1.Offset(1) = r1.Value
        r1.Offset(1).Select
        r1.Resize(1) = arr
    End If

End Sub

Any help would be kindly appreciatd.

[HansV]

Do these do what you want?

Code: Select all

Sub MoveDown()
    If Selection.Row + Selection.Rows.Count >= 54 Then
        MsgBox "Bottom reached"
    Else
        With Intersect(Range("E:O"), Selection.EntireRow)
            .Cut
            .Offset(.Rows.Count + 1).Insert Shift:=xlShiftDown
        End With
        Application.CutCopyMode = False
    End If
End Sub

Sub MoveUp()
    If Selection.Row <= 18 Then
        MsgBox "Top reached"
    Else
        With Intersect(Range("E:O"), Selection.EntireRow)
            .Cut
            .Offset(-1).Insert Shift:=xlShiftDown
        End With
        Application.CutCopyMode = False
    End If
End Sub

[adam]

Thanks for the help Hans. But this is just half of what I asked.

Unlike the code I had posted, your code does move rows up and down within the column range. However, it does not move the selection along with it. Instead, moves the data only. Every time the user has to select that same row if they want to move it further.

I want the selection also to move with the row as it moves either up or down.

Even though the range of the code is set between row 18 and 54 the user might have data only up to row 20. In this instance I want the code to display the message "Bottom Reached" when moving the data rows Down.

I hope I've made my question clear. Thanks in advance.

[HansV]

Try these then.

Code: Select all

Sub MoveDown()
    Dim rng As Range
    On Error Resume Next
    Set rng = Range("E18:O55").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If rng Is Nothing Then
        MsgBox "No data!"
    ElseIf Selection.Row + Selection.Rows.Count >= rng.Row + 1 Then
        MsgBox "Bottom reached"
    Else
        Set rng = Intersect(Range("E:O"), Selection.EntireRow)
        rng.Cut
        rng.Offset(rng.Rows.Count + 1).Insert Shift:=xlShiftDown
        rng.Select
        Application.CutCopyMode = False
    End If
End Sub

Sub MoveUp()
    Dim rng As Range
    If Selection.Row <= 18 Then
        MsgBox "Top reached"
    Else
        Set rng = Intersect(Range("E:O"), Selection.EntireRow)
        rng.Cut
        rng.Offset(-1).Insert Shift:=xlShiftDown
        rng.Select
       Application.CutCopyMode = False
    End If
End Sub

[adam]

Thanks a lot Hans. It worked very well.