Mar 16 2021 04:14 PM - edited Mar 17 2021 08:46 AM
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!
Mar 17 2021 03:41 AM
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
Mar 17 2021 08:21 AM
Mar 17 2021 08:38 AM
Mar 17 2021 08:47 AM
Mar 17 2021 09:04 AM
Mar 17 2021 10:01 AM - edited Mar 17 2021 10:03 AM
Solution
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
Mar 17 2021 12:15 PM - edited Mar 17 2021 12:18 PM
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
Mar 17 2021 02:36 PM
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
Mar 17 2021 03:22 PM
Mar 17 2021 11:22 PM
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
Mar 18 2021 02:08 AM
Mar 18 2021 03:10 AM - edited Mar 18 2021 04:49 AM
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
Mar 18 2021 06:12 AM
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.
Mar 17 2021 10:01 AM - edited Mar 17 2021 10:03 AM
Solution
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