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.
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.
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:
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.
|How to use a code to display the current date based on certain criteria|
|How to use VBA to change zero value to blank value based on criteria in other columns|
|How to add digit or replace last digit in string based on criteria|
|How to find and write cells based on criteria|