Thread: Move filled cell to right and insert blank cell

Hi,

Please could someone advise me on how to do the following. I am creating a task tracker to help me keep track of jobs. I would like it so that i can keep adding updates to the task until it is complete. The problem is i would like to be able to see the latest update without scrolling right all the time.

Is there some VBA that i can put in so that when i add an update in column k (attached) it auto moves the comments to the right one cell.

This would then mean that i can see the latest update without scrolling accross and only when i need to will i have to check the previous updates.

Any help would be appreciated. Thanks in advance.

Chemist

Hi,

I assume that after you enter a new value in column K and after the other comments have been shifted over one cell you want that value to be copied across to the now blank cell on the right. If not just leave out the second line in the code below which should be entered at the end of the Sheet Change event.

If Not Intersect(Target, Range("K6:K1000")) Is Nothing Then
        Target.Cells(1, 2).Insert Shift:=xlToRight
        Target.Copy Destination:=Target.Cells(1, 2)
End If

Hi,

Put it immediately before your main IF..End IF block.

Regards

Hi,

Yes that's the right place to put it. Are you sure you've added it to the sheet change event of the 'Open Tasks' sheet and not the 'Closed Tasks' sheet?

Here's a slight modification. It doesn't affect what I originally gave you which should run OK, but it just stops the macro using the IF test a second time when the entry is copied to the adjacent cell.

If Not Intersect(Target, Range("K6:K1000")) Is Nothing Then
        Application.EnableEvents = False
        Target.Cells(1, 2).Insert Shift:=xlToRight
        Target.Copy Destination:=Target.Cells(1, 2)
        Application.EnableEvents = True
End If

Hi, just add Target = "" as the penultimate line. i.e.

If Not Intersect(Target, Range("K6:K1000")) Is Nothing Then
        Application.EnableEvents = False
        Target.Cells(1, 2).Insert Shift:=xlToRight
        Target.Copy Destination:=Target.Cells(1, 2)
        Target = ""
        Application.EnableEvents = True
End If

Regards

Yes you called it correct. I was putting it in the closed task sheet. Obvious now but frustrating when i couldnt get it too work. Any idea on how i odify the code to keep the cell in column K blank after it has copied accross?

Sorry didn't see the above.

Thanks for your help with this

Does anyone know why i would be getting a run time error 1004 with the above script. It has two functions. One moves shifts data to the right one column when it is entered into column K

The other moves the entire row to the closed tab when column J is set to C. Both work independently of each other but not when combined. The columns are the same in the closed tab as the open.

When i go to debug it highlights the following line:

Target.Copy Destination:=Target.Cells(1, 2)

Any ideas? Again if this needs to be a new thread please let me know.

Edit: Also noted that deleting a row throws up the same error. It also knocks the whole row out of line by 1 column to the right?

Hi,

It seems to work OK for me. I'm pasting the whole code below since I've added the two Application.EnableEvents True/False lines in the second main IF.

Also you should delete the code in the 'Closed Tasks' sheet change event. It's redundant since everything is driven by the 'Open Tasks' sheet change event.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sColumn As String
    Dim lNextRow As Long
    Dim shTo As Worksheet
    Dim r As Range

    '********************************
    'Change these to the correct values
    sColumn = "J"
    Set shTo = Worksheets("Closed Tasks")
    '********************************

    If Not Intersect(Target, Range("K6:K1000")) Is Nothing Then
        Application.EnableEvents = False
        Target.Cells(1, 2).Insert Shift:=xlToRight
        Target.Copy Destination:=Target.Cells(1, 2)
        Target = ""
        Application.EnableEvents = True
    End If
    
    If Target.Count = 1 Then
        Set r = Target.Worksheet.Columns(sColumn & ":" & sColumn)
        If Not Intersect(Target, r) Is Nothing Then
            Application.EnableEvents = False
            If Target.Value = "C" Then
                With shTo
                    lNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    Target.EntireRow.Copy .Range("A" & lNextRow).EntireRow
                End With
                 Target.EntireRow.Delete
            End If
        End If
        Application.EnableEvents = True
    End If
End Sub