Move cell contents along using vba?

[Guest]

Hi,
I'm going to create a spreadsheet to monitor about 20 projects. Very simple
stuff but what I'd like to implement is when a cell in column C gets focus to
edit, all contents of that cell automatically move one cell to the right (to
D). Should that cell in D have contents, then it will also move one cell to
its right. And so on and so forth. The end result would be a sheet with the
most up to date info against the projects and the user could scroll right to
see a 'history' of amendments.
Any thoughts?
Thanks.

 

[Steve Yandl]

I think this might do what you want. The subroutine needs to be placed in
the worksheet rather than a module or the workbook.

_____________________________

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngTemp As Range
Dim rngTempA As Range
If Target.Column = 3 And Not Target.Value = "" Then
Application.EnableEvents = False
Set rngTemp = Cells(Target.Row, 256).End(xlToLeft)
Set rngTempA = Range(Target.Address & ":" & rngTemp.Address)
rngTempA.Cut Destination:=Target.Offset(0, 1)
Application.EnableEvents = True
End If
End Sub

_____________________________

Steve

 

[Guest]

Great stuff, Steve.
I have noticed that, should the user use 'down arrow' whilst in in column C,
all data moves one cell to the right for each row so I wonder if the code can
be made 'user proof' in as much that cell contents only move when user starts
to type in to a cell in C?

Many thanks
--
Traa Dy Liooar

Jock

I think this might do what you want. The subroutine needs to be placed in
the worksheet rather than a module or the workbook.

_____________________________

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngTemp As Range
Dim rngTempA As Range
If Target.Column = 3 And Not Target.Value = "" Then
Application.EnableEvents = False
Set rngTemp = Cells(Target.Row, 256).End(xlToLeft)
Set rngTempA = Range(Target.Address & ":" & rngTemp.Address)
rngTempA.Cut Destination:=Target.Offset(0, 1)
Application.EnableEvents = True
End If
End Sub

_____________________________

Steve

 

[Steve Yandl]

Jock,

If the shift of data to the right can't occur until the user starts typing,
you would be asking users to begin typing into a cell that already contains
data. I think that would cause more discomfort for your users. At worse,
the data would only be moved over once, even if the user made multiple
excursions up and down the column with the arrow keys since the subroutine
doesn't move anything if the cell selected in column C happens to be empty
when the user selects the cell.

One option would be to create a cleanup subroutine that could be manually
run by the user or tied to some event like the 'BeforeSave' event for the
workbook. The routine could check column D and for every cell where data
was found, check column C of the same row for data. If there was data in
the D cell and the corresponding C cell was empty, the data could be moved
once cell to the left, effectively undoing what the user had inadvertently
caused earlier.

Steve

Great stuff, Steve.
I have noticed that, should the user use 'down arrow' whilst in in column
C,
all data moves one cell to the right for each row so I wonder if the code
can
be made 'user proof' in as much that cell contents only move when user
starts
to type in to a cell in C?

Many thanks

 

[Guest]

Ok, fair point. How about if a user moves into a cell (C) and then moves out
again without inputting, could the code be adapted to "undo" the movement to
the right?

Thanks for your input.

 

[Steve Yandl]

See if this does what you want.

___________________________________________

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngTempX As Range
Dim rngTempEnd As Range
Dim rngTempA As Range
Dim rngTempAend
Dim rngTempB As Range
Dim rngTempBend As Range

If Target.Column = 3 Then
Application.EnableEvents = True

If Target.Row > 1 Then
If Target.Offset(-1, 0).Text = "" Then
If Not Target.Offset(-1, 1).Text = "" Then
Set rngTempAend = Cells(Target.Row - 1, 256).End(xlToLeft)
Set rngTempA = Range(Target.Offset(-1, 1).Address & ":" &
rngTempAend.Address)
rngTempA.Cut Destination:=Target.Offset(-1, 0)
End If
End If
End If

If Target.Offset(1, 0).Text = "" Then
If Not Target.Offset(1, 1).Text = "" Then
Set rngTempBend = Cells(Target.Row + 1, 256).End(xlToLeft)
Set rngTempB = Range(Target.Offset(1, 1).Address & ":" &
rngTempBend.Address)
rngTempB.Cut Destination:=Target.Offset(1, 0)
End If
End If

If Not Target.Text = "" Then
Set rngTempEnd = Cells(Target.Row, 256).End(xlToLeft)
Set rngTempX = Range(Target.Address & ":" & rngTempEnd.Address)
rngTempX.Cut Destination:=Target.Offset(0, 1)
End If

Application.EnableEvents = True
End If
End Sub
____________________________________________

 

[Steve Yandl]

Don't know how I got Application.EnableEvents = True in there twice but it
seemed to work when I tested. Try what I've got below instead.


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngTempX As Range
Dim rngTempEnd As Range
Dim rngTempA As Range
Dim rngTempAend
Dim rngTempB As Range
Dim rngTempBend As Range

If Target.Column = 3 Then
Application.EnableEvents = False

If Target.Row > 1 Then
If Target.Offset(-1, 0).Text = "" Then
If Not Target.Offset(-1, 1).Text = "" Then
Set rngTempAend = Cells(Target.Row - 1, 256).End(xlToLeft)
Set rngTempA = Range(Target.Offset(-1, 1).Address & ":" &
rngTempAend.Address)
rngTempA.Cut Destination:=Target.Offset(-1, 0)
End If
End If
End If

If Target.Offset(1, 0).Text = "" Then
If Not Target.Offset(1, 1).Text = "" Then
Set rngTempBend = Cells(Target.Row + 1, 256).End(xlToLeft)
Set rngTempB = Range(Target.Offset(1, 1).Address & ":" &
rngTempBend.Address)
rngTempB.Cut Destination:=Target.Offset(1, 0)
End If
End If

If Not Target.Text = "" Then
Set rngTempEnd = Cells(Target.Row, 256).End(xlToLeft)
Set rngTempX = Range(Target.Address & ":" & rngTempEnd.Address)
rngTempX.Cut Destination:=Target.Offset(0, 1)
End If

Application.EnableEvents = True
End If
End Sub

 

[Guest]

That's got it. Thanks very much Steve.
Nice one