Reverse paste column VBA

[Jacob45678]

Hi I would like to reverse paste a column, but the column is going downwards when pasted.

Below is a code referred from other post but its not working


Sub RevPast()

Dim Rws As Long
Dim cols As Long
Dim Dest As Range
Dim SRng As Range
Dim i As Long
Dim r As Long

r = 1
Rws = Selection.Rows.Count
cols = Selection.Columns.Count
Set SRng = Selection
Set Dest = Application.InputBox("Select start point of paste range", Type:=8)

For i = Rws To 1 Step -1
SRng.Rows(i).Copy Dest(r)
r = r + 1
Next i

End Sub

 

[Kaper]

Looking at your second screenshot, I wouldn't call the operation a reverse copy.
I'd call it: copy to location ending in a selected cell. If this descripion is fine (If I understood your needs well) - try such code:

Sub PasteFromLastCellUpwards()
Dim Rws As Long
Dim Dest As Range
Dim SRng As Range

Set SRng = Selection
Rws = SRng.Rows.Count
Set Dest = Application.InputBox("Select end point of paste range", Type:=8)
if Dest.row <Rws then
  msgbox "Sorry the copy wouldn't fit above",vbcritical
else
 SRng.Copy Dest.offset(-Rws+1,0)
end if
End Sub

 

[Jacob45678]

Looking at your second screenshot, I wouldn't call the operation a reverse copy.
I'd call it: copy to location ending in a selected cell. If this descripion is fine (If I understood your needs well) - try such code:

Sub PasteFromLastCellUpwards()
Dim Rws As Long
Dim Dest As Range
Dim SRng As Range

Set SRng = Selection
Rws = SRng.Rows.Count
Set Dest = Application.InputBox("Select end point of paste range", Type:=8)
if Dest.row <Rws then
  msgbox "Sorry the copy wouldn't fit above",vbcritical
else
 SRng.Copy Dest.offset(-Rws+1,0)
end if
End Sub

Works like a charm. Appreciate the kind help.

I have added an extra line to select the desired range to move.

Sub PasteFromLastCellUpwards()
Dim Rws As Long
Dim Dest As Range
Dim SRng As Range

ActiveSheet.Range("C3:C8").Select 'desired range to move
Set SRng = Selection
Rws = SRng.Rows.Count
Set Dest = Application.InputBox("Select end point of paste range", Type:=8)
If Dest.Row < Rws Then
MsgBox "Sorry the copy wouldn't fit above", vbCritical
Else
SRng.Copy Dest.Offset(-Rws + 1, 0)
End If
End Sub

 

[Kaper]

If that's constant range, Select ... Selection is a bad idea. You can directly use the operations on this (known) range.
And please note how usung CODE tags - see small icons next to standard formatting - (bold, Italic, ... smileys, ...) above the text when you write a reply or edit your post.

Sub PasteFromLastCellUpwards()
Dim Rws As Long, Dest As Range, SRng As Range

Set SRng = ActiveSheet.Range("C3:C8")
Rws = SRng.Rows.Count
Set Dest = Application.InputBox("Select end point of paste range", Type:=8)
If Dest.Row < Rws Then
  MsgBox "Sorry the copy wouldn't fit above", vbCritical
Else
  SRng.Copy Dest.Offset(-Rws + 1, 0)
End If
End Sub