Copy to New Worksheet with VBA

[Hydestone]

Hi All:

I've got a worksheet that includes a running list of To Do items for various projects. Right now it shows both closed and open items in the same list. I use filters to hide closed items.

I close an item by putting an X in column A, which then puts the date closed in column K.

How would I write the VBA to copy that entire row of data to a worksheet called "Closed" when I add the X to column A? So that I can have a worksheet with all of the closed items? As I close off items, they would continue to automatically copy to that sheet.

Also, can you think of a way to have another sheet that would only show open items, ie those without an X in column A? Perhaps have it display on a worksheet called "Open." So that when an item is X'd off on my To Do tab, it drops off the Open sheet.

Open to suggestions if there is a better way to organize this stuff.

Thanks!

 

[mumps]

Make sure that you have a sheet named "Closed" and another one named "Open". Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your To Do sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter an "x" or delete the "x" in column A and press the RETURN key. The macro also places a date in column K.

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Dim LastRow As Long
    LastRow = Sheets("Open").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    If Target = "X" Then
        Target.Offset(0, 10) = Date
        Rows(Target.Row).EntireRow.Copy Sheets("Closed").Cells(Sheets("Closed").Rows.Count, "A").End(xlUp).Offset(1, 0)
    ElseIf Target = "" Then
        Rows(Target.Row).EntireRow.Copy Sheets("Open").Cells(LastRow, 1)
    End If
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Hydestone]

Mumps - I appreciate the quick response!

I added that code and got the debugger gave me run time error 91 when putting an X in column A and brought me to this line:

LastRow = Sheets("Open").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1


Also, I had this code in the worksheet to add the closed date. I removed it before putting in your code.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
For Each c In Target
Select Case c.Column
Case Is = 1
If c.Value = "X" And c.Offset(, 10) = "" Then c.Offset(, 10) = Date
Case Is = 3
If c.Offset(, -1) = "" Then c.Offset(, -1) = Date
End Select
Next
End If
End Sub

 

[Hydestone]

Shameless bump...anyone have suggestions on how to debug this code?

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
Dim LastRow As Long
LastRow = Sheets("Open").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If Target = "X" Then
Target.Offset(0, 10) = Date
Rows(Target.Row).EntireRow.Copy Sheets("Closed").Cells(Sheets("Closed").Rows.Count, "A").End(xlUp).Offset(1, 0)
ElseIf Target = "" Then
Rows(Target.Row).EntireRow.Copy Sheets("Open").Cells(LastRow, 1)
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[mumps]

Try this version:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Dim LastRow As Long
    LastRow = Sheets("Open").Range("B" & Rows.Count).End(xlUp).Row + 1
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    If Target = "X" Then
        Target.Offset(0, 10) = Date
        Rows(Target.Row).EntireRow.Copy Sheets("Closed").Cells(Sheets("Closed").Rows.Count, "A").End(xlUp).Offset(1, 0)
    ElseIf Target = "" Then
        Rows(Target.Row).EntireRow.Copy Sheets("Open").Cells(LastRow, 1)
    End If
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Hydestone]

Great, that works! Thanks so much Mumps!

I was using the below code to add the date in column B when I entered a value in column C. Are you able to incorporate that into your code?

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
For Each c In Target
Select Case c.Column
Case Is = 1
If c.Value = "X" And c.Offset(, 10) = "" Then c.Offset(, 10) = Date
Case Is = 3
If c.Offset(, -1) = "" Then c.Offset(, -1) = Date
End Select
Next
End If
End Sub

 

[mumps]

In order for this macro to work properly, you must make sure that the column letter (in red) is a column in the To Do sheet that will not have any blank cells.

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A,C:C")) Is Nothing Then Exit Sub
    Dim LastRow As Long
    LastRow = Sheets("Open").Range("[COLOR="#FF0000"]C[/COLOR]" & Rows.Count).End(xlUp).Row + 1
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Select Case Target.Column
        Case Is = 1
            If Target = "X" And Target.Offset(, 10) = "" Then
                Target.Offset(0, 10) = Date
                Rows(Target.Row).EntireRow.Copy Sheets("Closed").Cells(Sheets("Closed").Rows.Count, "A").End(xlUp).Offset(1, 0)
            ElseIf Target = "" Then
                Rows(Target.Row).EntireRow.Copy Sheets("Open").Cells(LastRow, 1)
            End If
        Case Is = 3
            If Target.Offset(, -1) = "" Then Target.Offset(, -1) = Date
    End Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub