Forum Discussion

Copper Contributor

Mar 16, 2021

Solved

VBA formula for archiving

Hi everyone, I've come across a very useful VBA formula for archiving data in my tables onto another sheet. The formula is as follows: Application.EnableEvents = False If Target.Column = 4 A...

EXAMPLE VBA ERROR.xlsm82 KB

excel

Macros and VBA

Subodh_Tiwari_sktneer

Mar 17, 2021

Jarvo

You placed the code for Selection Change Event on Current Sheet Module. Was it intentional or you did it by mistake?

Ideally you should place the code for Change Event so that when Status gets changed in Status column of the Table on Current Sheet, the data will be copied to the Saved or Archive Sheet accordingly based on the Status selected.

Please place the following code for Change Event on Current Sheet Module. In the attached I placed the code on Current Sheet Module for you to test it.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tbl As ListObject
Dim rng As Range
Dim dws As Worksheet
Dim dlr As Long

Application.ScreenUpdating = False
On Error GoTo Skip

Set tbl = ActiveSheet.ListObjects("Table1")
If Not Intersect(Target, tbl.DataBodyRange.Columns(4)) Is Nothing Then
    Application.EnableEvents = False
    Set rng = Intersect(ActiveSheet.Rows(Target.Row), Columns("A:G"))
    rng.Copy
    Select Case Target.Value
        Case "Save"
            Set dws = ThisWorkbook.Worksheets("Saved")
        Case "Closed"
            Set dws = ThisWorkbook.Worksheets("Archive")
    End Select
    dlr = dws.Cells(Rows.Count, "D").End(xlUp).Row + 1
    dws.Range("A" & dlr).PasteSpecial xlPasteAll
End If
Skip:
Application.CutCopyMode = 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

EXAMPLE VBA ERROR.xlsm85 KB

Subodh_Tiwari_sktneer

Silver Contributor

Mar 17, 2021

Jarvo

You placed the code for Selection Change Event on Current Sheet Module. Was it intentional or you did it by mistake?

Please place the following code for Change Event on Current Sheet Module. In the attached I placed the code on Current Sheet Module for you to test it.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tbl As ListObject
Dim rng As Range
Dim dws As Worksheet
Dim dlr As Long

Application.ScreenUpdating = False
On Error GoTo Skip

Set tbl = ActiveSheet.ListObjects("Table1")
If Not Intersect(Target, tbl.DataBodyRange.Columns(4)) Is Nothing Then
    Application.EnableEvents = False
    Set rng = Intersect(ActiveSheet.Rows(Target.Row), Columns("A:G"))
    rng.Copy
    Select Case Target.Value
        Case "Save"
            Set dws = ThisWorkbook.Worksheets("Saved")
        Case "Closed"
            Set dws = ThisWorkbook.Worksheets("Archive")
    End Select
    dlr = dws.Cells(Rows.Count, "D").End(xlUp).Row + 1
    dws.Range("A" & dlr).PasteSpecial xlPasteAll
End If
Skip:
Application.CutCopyMode = 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

EXAMPLE VBA ERROR.xlsm85 KB

Jarvo

Copper Contributor

Mar 17, 2021

This is perfect thank you! I followed an online YouTube guide so it was from there that I had placed the code into the selection change. Thank you for rectifying that! I have one more request - Do you have a code so that when the data has been copied onto the Archive sheet, the row is then deleted from the Current sheet in the same process? I hope that makes sense

Subodh_Tiwari_sktneer

Silver Contributor

Mar 17, 2021

Jarvo

You're welcome! Glad it worked as desired.

To do that, please replace the existing code with the following one...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tbl As ListObject
Dim rng As Range
Dim dws As Worksheet
Dim dlr As Long

Application.ScreenUpdating = False
On Error GoTo Skip

Set tbl = ActiveSheet.ListObjects("Table1")
If Not Intersect(Target, tbl.DataBodyRange.Columns(4)) Is Nothing Then
    Application.EnableEvents = False
    Set rng = Intersect(ActiveSheet.Rows(Target.Row), Columns("A:G"))
    rng.Copy
    Select Case Target.Value
        Case "Save"
            Set dws = ThisWorkbook.Worksheets("Saved")
        Case "Closed"
            Set dws = ThisWorkbook.Worksheets("Archive")
    End Select
    dlr = dws.Cells(Rows.Count, "D").End(xlUp).Row + 1
    dws.Range("A" & dlr).PasteSpecial xlPasteAll
    Rows(Target.Row).Delete
End If
Skip:
Application.CutCopyMode = 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Jarvo

Copper Contributor

Mar 17, 2021

This is great and works a treat. However I'd like it so that the row is deleted when ONLY "Closed" is selected for it to be copied onto the Archive sheet, I don't want the row deleted when "save" is selected for the Saved sheet. How do I do that please?

Subodh_Tiwari_sktneer

Silver Contributor

Mar 18, 2021

Jarvo

Sorry, I missed that point whereas you mentioned it in your last post.
Anyways, please try the code given below...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tbl     As ListObject
Dim rng     As Range
Dim dws     As Worksheet
Dim dlr     As Long
Dim Closed  As Boolean

Application.ScreenUpdating = False
On Error GoTo Skip

Set tbl = ActiveSheet.ListObjects("Table1")
If Not Intersect(Target, tbl.DataBodyRange.Columns(4)) Is Nothing Then
    Application.EnableEvents = False
    Set rng = Intersect(ActiveSheet.Rows(Target.Row), Columns("A:G"))
    rng.Copy
    Select Case Target.Value
        Case "Save"
            Set dws = ThisWorkbook.Worksheets("Saved")
        Case "Closed"
            Set dws = ThisWorkbook.Worksheets("Archive")
            Closed = True
    End Select
    dlr = dws.Cells(Rows.Count, "D").End(xlUp).Row + 1
    dws.Range("A" & dlr).PasteSpecial xlPasteAll
    If Closed Then Rows(Target.Row).Delete
End If
Skip:
Application.CutCopyMode = 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub