SOLVED

VBA formula for archiving

Occasional Contributor

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 And UCase(Target) = "COMPLETED" Then

Cells(Target.Row, Target.Column).EntireRow.Copy Destination:=Sheets("Archive").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

Application.EnableEvents = True

 

However, I can't work out how to archive data in columns A:G only, instead of the entire row. I'm new to VBA and can't work this one out. Is anyone able to help? Many thanks!

15 Replies

@Jarvo 

I'm not sure I got it right, but would you like it to be copied to columns A to G? And the inserted "A: G" in your example?

 

Application.EnableEvents = False

If Target.Column = 4 And UCase(Target) = "COMPLETED" Then

Cells(Target.Row, Target.Column).EntireRow.Copy Destination:=Sheets("Archive").Range("A:G" & Rows.Count).End(xlUp).Offset(1)

End If

Application.EnableEvents = True

 

Hope I could help you,

if this is not what you are looking for, please ignore it.

 

Thank you for your time and patience.

 

Nikolino

 

I did try that but it didn't work. Thanks for your help though!
Would it be possible to have the whole file (without sensitive data) or code?
So I could better understand what exactly you want to achieve. Correspondingly, if I am able to offer you a better proposal for a solution.
Great yeah I've just added a copy without the data. I am also having trouble with highlighting whole columns and rows and deleting them due to this formula. If you're able to work that out too you're a star. Thanks
If you could briefly explain what exactly you want to accomplish, it would be great.
From where to where should the data go?
Column, row, cell.
Does it necessarily have to be in VBA, should one also make a proposed solution without vba?

Thank you for your patience and understanding
best response confirmed by Jarvo (Occasional Contributor)
Solution

@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

 

 

 

 

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

@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
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?

@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
Wonderful! This is everything I needed. You've done me a great service Sir. Thank you so much I really appreciate it. Your skills are evident.

Best wishes
Jarvo

I just thought that it would be good to have a similar code for the 'Archive' sheet, where the "Open Risks" selection would copy that row back into the 'Current' sheet and delete it in the same process. And also be able to copy the row into the 'Saved' Sheet upon "Save" selection but without deleting it in the same process. Would you be able to advise please or come up with a code for that? Your help is really appreciated.

 

P.s. The existing code for both the 'Archive' and 'Saved' Sheets I've deleted

@Jarvo 

 

Place the following codes on the Sheet Modules as below...

 

Codes for Current Sheet Module:

Private Sub Worksheet_Activate()
Dim wsArchive       As Worksheet
Dim lr              As Long
Dim i               As Long
Dim dlr             As Long
Dim rng             As Range

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error GoTo Skip

Set wsArchive = ThisWorkbook.Worksheets("Archive")
lr = wsArchive.Cells(Rows.Count, "D").End(xlUp).Row

For i = 4 To lr
    If wsArchive.Cells(i, "D") = "Open Risks" Then
        Set rng = wsArchive.Range("A" & i & ":G" & i)
        dlr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        rng.Copy Range("A" & dlr)
        rng.Delete
    End If
Next i

Skip:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

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

 

Codes for Saved Sheet Module:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myDateTimeRange As Range

If Target.Column <= 7 And Target.Row > 3 Then
    'Stop events from running
    Application.EnableEvents = False
    
    'Column for the date/time
    Set myDateTimeRange = Range("T" & Target.Row)
    'Column for last updated date/time
    
    'Determine if the input date/time should change
    If myDateTimeRange.Value = "" Then
    
        myDateTimeRange.Value = Now
    
    End If
    
    'Update the updated date/time value
    
    'Turn events back on
    Application.EnableEvents = True
End If
End Sub

 

Codes for Archive Sheet Module:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim wsSaved         As Worksheet
Dim myDateTimeRange As Range
Dim r               As Long
Dim dlr             As Long
Dim rng             As Range

On Error GoTo Skip

Application.ScreenUpdating = False

Set wsSaved = ThisWorkbook.Worksheets("Saved")

'Stop events from running
Application.EnableEvents = False

If Target.Column = 4 And Target.Row > 3 Then
    If Target.Value = "Save" Then
        r = Target.Row
        dlr = wsSaved.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        Set rng = Range("A" & r & ":G" & r)
        rng.Copy wsSaved.Range("A" & dlr)
    End If
ElseIf Target.Column <= 7 And Target.Row > 3 Then
    
    'Column for the date/time
    Set myDateTimeRange = Range("T" & Target.Row)
    'Column for last updated date/time
    
    'Determine if the input date/time should change
    If myDateTimeRange.Value = "" Then
        myDateTimeRange.Value = Now
    End If
        
End If
Skip:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

As per the Worksheet_Activate Code on Current Sheet Module, once you change the status of a risk in to Open Risks (in column D on Archive Sheet) and you select the Current Sheet, the risk for which you changed the status on Archive Sheet as Open Risks, will be transferred to the Current Sheet automatically and will be deleted from Archive Sheet.

 

Similarly when you change the status of a risk to Save on Archive Sheet, that row will be copied to the Saved Sheet without deleting that row on Archive Sheet.

 

I have placed all the codes on the Sheet Modules for you to test it.

 

 

This is perfect, thank you!
You're welcome @Jarvo!