Macro for Automatically Moving Data between Sheets

[BeckySW]

Hi there,


I have rows of data in a sheet (sheet is named "Grant") that I would like to move to a new sheet named "Archive" automatically, once "Yes" has been selected from the dropdown box in column AK (data starts at row 9) in the "Grant" sheet. I would also like it to delete the row in the "Grant" sheet, so it is not showing in two places.

Hopefully this makes sense, please help!!!





Thanks in advance.

 

[steve the fish]

Hi. Try this. Use it on a dummy workbook first.

Sub MoveToArchive()

Application.ScreenUpdating = False
 
Dim lr As Long, lrArch As Long

lrArch = Sheets("Archive").Range("AK" & Sheets("Archive").Rows.Count).End(xlUp).Row + 1
With Sheets("Grant")
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("AK" & .Rows.Count).End(xlUp).Row
    If lr < 9 Then Exit Sub
    With .Range("AK8:AK" & lr)
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:="Yes"
        If .SpecialCells(xlCellTypeVisible).Count > 1 Then
            .Offset(1, 0).Resize(lr - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
            Sheets("Archive").Range("A" & lrArch).PasteSpecial xlPasteValues
            .Offset(1, 0).Resize(lr - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End If
    End With
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

 

[BeckySW]

Thank you! Gave it a try and it keeps giving me runtime error "1004" back - says pastespecial method of range class failed. (see below)





Sub MoveToArchive()

Application.ScreenUpdating = False

Dim lr As Long, lrArch As Long
lrArch = Sheets("Archive").Range("AK" & Sheets("Archive").Rows.Count).End(xlUp).Row + 1
With Sheets("Grant")
If .AutoFilterMode Then .AutoFilterMode = False
lr = .Range("AK" & .Rows.Count).End(xlUp).Row
If lr < 9 Then Exit Sub
With .Range("AK8:AK" & lr)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="Yes"
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
.Offset(1, 0).Resize(lr - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("Archive").Range("A" & lrArch).PasteSpecial xlPasteValues (this is highlighted when debugging)
.Offset(1, 0).Resize(lr - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
.AutoFilterMode = False
End With




I just copied over the format from the "Grant" sheet so that it would remain the same, there are also two hidden columns in this format, could that be causing issues?

 

[steve the fish]

I'm not sure that is the issue but you could always try making them visible and trying again.