How to Move row contents to annother sheet based on criteria

How to move row contents to another sheet based on criteria

Requirements:

The user has a sheet that they would like to move the contents the row to another sheet based on the cell percentage in column 'J' = 100% and the button at the top of the page pressed.

A sample spreadsheet has been attached.

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/149037-move-row-contents-to-annother-sheet-based-on-criteria

Supplier:

Place the following code on a Standard Module and assign it to the shape you have on the Asbestos sheet by right clicking on the shape and choose Assign Macro and select the macro CopyToArchive and click OK.

Code:

Sub CopyToArchive()
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long
Application.ScreenUpdating = False

Set sws = Sheets("Asbestos")
Set dws = Sheets("Asbestos-Archive")
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
sws.AutoFilterMode = False
With sws.Rows(3)
    .AutoFilter Field:=10, Criteria1:="100%"
    If sws.Range("A3:A" & slr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        sws.Range("A4:AG" & slr).SpecialCells(xlCellTypeVisible).Copy
        dws.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
        sws.Range("A4:AG" & slr).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End If
End With
sws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

If you don't want to delete the rows after copying them to Archive sheet, remove the following line from the code...

An alternative method which would be faster if there are many rows of data that need moving.

Assign this to the button:

Code:

Sub ArchiveData()
    Dim x, y(), i As Long, ii As Long, iii As Long
    
    With Sheets("Asbestos").Cells(3, 1).CurrentRegion
        x = .Value
        For i = 2 To UBound(x, 1)
            If x(i, 10) = 1 Then
                ii = ii + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ii)
                For iii = 1 To UBound(y, 1)
                    y(iii, ii) = x(i, iii)
                Next
                x(i, 1) = ""
            End If
        Next
        .Value = x
        .Columns(1).SpecialCells(4).EntireRow.Delete
    End With
    With Sheets("Asbestos-Archive")
        i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(i, 1).Resize(UBound(y, 2), UBound(y, 1)) = Application.Transpose(y)
        .Columns.AutoFit
        .Columns(11).ColumnWidth = 10
        .Rows(4).Resize(ii).RowHeight = 32.25
    End With
        
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by sktneer and KjBox.