How to move row contents to another sheet based on criteria
Category: [Excel] Demo Available
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.
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...
OR
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.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| 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 |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.