How can I run these macros together across every worksheet in the workbook? - excel

I have made an excel book, where a data set is pasted into one tab, and macros are run to filter out the information into seperate worksheets, ready to batch PDF. Currently I have a button on each sheet to 'Update Table' and have to go through each sheet to click this button. I want this as one button on the first sheet. I also have a button to set the print area on all sheets - this one loops and works fine. I'd like to merge the codes, so one button will go through each sheet to update the tables, and then set the print area.
I have tried merging these codes together with no luck so far despite hours of googling, so thought I'd try here. I'm very new to VBA (just been teaching myself for a few weeks).
Sub Auto_Table_Update()
Sheets("All Data").Range("A50:K9999").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("C2:C3"), CopyToRange:=Range("A5:K9999"), Unique:= _
False
'*Advance Filter Macro to update the table in the worksheet*
Range("C4").Select
ActiveCell.FormulaR1C1 = "=LEFT(R[-1]C,3)"
Range("C5").Select
'*Sets the worksheet name as the first 3 letters in cell C4*
End Sub
Sub Workbook_Print_Area()
Dim ws As Worksheet
Dim LR As Long, _
LC As Long
For Each ws In ActiveWorkbook.Worksheets
With ws
LR = .Range("A" & Rows.Count).End(xlUp).Row
LC = .Cells(1, Columns.Count).End(xlToLeft).Column
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(LR, LC)).Address
End With
' *sets the print area on every sheet*
Next ws
End Sub
Like I said, I just want one button to run the above codes on every sheet. Or at least the 'Auto_Update_Table' to be run on every sheet rather than having a button to run it on each sheet like I currently do.
I appreciate some of it will be badly coded.. Any explanations of the changes would be much appreciated too. I appreciate your patience.. I am trying to get my head around all this :)
UPDATE
I have tried doing this:
Sub One_Button()
Dim ws As Worksheet
Dim LR As Long, _
LC As Long
For Each ws In ActiveWorkbook.Worksheets
With ws
Sheets("All Data").Range("A50:K9999").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("C2:C3"), CopyToRange:=Range("A5:K9999"), Unique:= _
False
Range("C4").Select
ActiveCell.FormulaR1C1 = "=LEFT(R[-1]C,3)"
Range("C5").Select
LR = .Range("A" & Rows.Count).End(xlUp).Row
LC = .Cells(1, Columns.Count).End(xlToLeft).Column
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(LR, LC)).Address
End With
Next ws
End Sub
This gives me the error 'The extract range has a missing or invalid field name.' Is this because it is trying to run on the first worksheet (with the main data set)? If so, how do I tell it to ignore the main data set sheet?
Thanks in advance :)

Can you try this? You need to make sure your criteria range includes the correct headers and doesn't have any spaces.
Sub One_Button()
Dim ws As Worksheet
Dim LR As Long, _
LC As Long
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "All Data" Then
With ws
Sheets("All Data").Range("A50:K9999").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("C2:C3"), CopyToRange:=ws.Range("A5"), Unique:=False
ws.Range("C4").FormulaR1C1 = "=LEFT(R[-1]C,3)"
LR = .Range("A" & Rows.Count).End(xlUp).Row
LC = .Cells(1, Columns.Count).End(xlToLeft).Column
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(LR, LC)).Address
End With
End If
Next ws
End Sub

Related

How to Copy and Append filtered data sourced from multiple sheets into a single destination sheet using a loop?

EDIT: I've pasted some revised code below in the Sub(Copyinternal) section. Still doesn't work but maybe I'm on the right track?
I have a workbook with 6 tabs. Sheets are set up as follows:
Controls
Forecast
Financial Update
Board Goals
Internal Calendar
External Calendar
Sheets 2-4 contain data tables that I would like to filter in two different ways and copy/paste to both tabs 5 & 6 without overwriting.
Sheets 5 & 6 have headers in row 1 that I would like to maintain.
Trying to:
First delete any existing information in "Internal Calendar" sheet and "External Calendar" sheet from Row 2 down without deleting the headers.
In "Forecast" sheet, filter column H on selections "Both" and "Internal" in and then copy/paste that information into "Internal Calendar" sheet starting in column C. I'm then trying to do the same for "Financial Update" and "Board Goals" sheets, but Copy/Pasting the filtered information after the content that's already been pasted into "Internal Calendar", as to not overwrite information.
Repeat step 2 except Filter H on "Both" and "External" and Copy/Paste the filtered info into "External Calendar" starting in column C.
Controls sheet can be ignored.
Loop begins to run correctly only if I run the macro while my active sheet is "Forecast", but then it stops after pasting that data and doesn't move onto the following two sheets. I'm also not entirely sure the existing code I have will identify the first empty row to append data to in the destination sheets.
I'm pretty new to using VBA, so a guide in the right direction would be very appreciated.
Sub CalendarAutomation()
ClearSheets
CopyInternal
CopyExternal
End Sub
Sub ClearSheets()
'Clear out Contents
Sheets("Internal Calendar").Select
activesheet.Range("C2:G250").Select
Selection.ClearContents
Sheets("External Calendar").Select
Range("C2:G250").Select
Selection.ClearContents
End Sub
Sub CopyInternal()
Dim ws As Variant
Dim starting_ws As Worksheet
Dim ending_ws As Worksheet
Dim rng As range
Set starting_ws = ThisWorkbook.Worksheets("Forecast")
Set ending_ws = ThisWorkbook.Worksheets("Internal Calendar")
Set rng = ActiveRange
For ws = 2 To 4
If Selection.AutoFilter = OFF Then Selection.AutoFilter
ws.rng.AutoFilter Field:=6, Criteria1:="=Both", _
Operator:=xlOr, Criteria2:="=Internal"
UsedRange.Copy
ending_ws.range(Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row).Paste
Next ws
End Sub
Sub CopyExternal()
Dim ws As Worksheet
Dim unusedRow As Long
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Controls" _
And Not ws.Name = "Internal Calendar" _
And Not ws.Name = "External Calendar" Then
Range("$C$3:$H$14").AutoFilter Field:=6, Criteria1:="=Both", _
Operator:=xlOr, Criteria2:="=External"
Range("C4:G14").Select
Selection.Copy
Sheets("External Calendar").Select
activesheet.Paste
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
End If
Next ws
End Sub
Try this:
Sub tst()
Dim ctrl As Worksheet: Set ctrl = ThisWorkbook.Sheets("Controls")
Dim fcast As Worksheet: Set fcast = ThisWorkbook.Sheets("Forecast")
Dim fu As Worksheet: Set fu = ThisWorkbook.Sheets("Financial Update")
Dim bg As Worksheet: Set bg = ThisWorkbook.Sheets("Board Goals")
Dim ic As Worksheet: Set ic = ThisWorkbook.Sheets("Internal Calendar")
Dim ec As Worksheet: Set ec = ThisWorkbook.Sheets("External Calendar")
Dim ic_last_r As Long
Dim ec_last_r As Long
ic_last_r = ic.Cells(ic.Rows.Count, 3).End(xlUp).Row
ec_last_r = ec.Cells(ec.Rows.Count, 3).End(xlUp).Row
If ic_last_r < 2 Then ic_last_r = 2 'avoid deleting 1st row
If ec_last_r < 2 Then ec_last_r = 2
ic.Rows("2:" & ic_last_r).ClearContents
ec.Rows("2:" & ec_last_r).ClearContents
copy_paste fcast, ic, "Both", "Internal", Array("Controls", "Forecast", "External Calendar")
copy_paste fcast, ec, "Both", "External", Array("Controls", "Forecast", "Internal Calendar")
End Sub
Sub copy_paste(ws1 As Worksheet, ws2 As Worksheet, c1 As String, c2 As String, wsheets)
Dim ws As Worksheet
Dim ws2_last_r As Long
For Each ws In ThisWorkbook.Worksheets
For i = LBound(wsheets) To UBound(wsheets)
If ws.Name = wsheets(i) Then GoTo n_ext
Next
ws2_last_r = ws2.Cells(ws2.Rows.Count, 3).End(xlUp).Row
ws1.Range("A1").AutoFilter 8, c1, xlOr, c2
ws1.Range("A1").CurrentRegion.Columns("C:G").Copy
ws2.Range("C" & ws2_last_r).PasteSpecial xlPasteAll
ws1.Range("A1").AutoFilter
n_ext:
Next
End Sub
Your code after changes (I hope it will work for you but there is a space for improvement):
Sub CalendarAutomation()
ClearSheets
CopyInternal
CopyExternal
End Sub
Sub ClearSheets()
'Clear out Contents
Sheets("Internal Calendar").Range("C2:G250").ClearContents
Sheets("External Calendar").Range("C2:G250").ClearContents
End Sub
Sub CopyInternal()
Dim ws As Variant
Dim starting_ws As Worksheet
Dim ending_ws As Worksheet
Dim rng As Range
Set starting_ws = ThisWorkbook.Worksheets("Forecast")
Set ending_ws = ThisWorkbook.Worksheets("Internal Calendar")
For ws = 2 To 4
If Sheets(ws).AutoFilterMode Then Sheets(ws).Range("A1").AutoFilter
Sheets(ws).Range("A1").AutoFilter 6, "Both", xlOr, "Internal"
Sheets(ws).UsedRange.Copy
ending_ws.Cells(ending_ws.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row, 3).PasteSpecial xlPasteAll 'pasting into "C" column
Next ws
End Sub
Sub CopyExternal()
Dim ws As Worksheet
Dim unusedRow As Long
Dim external As Worksheet: Set external = ThisWorkbook.Worksheets("External Calendar")
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Controls" _
And Not ws.Name = "Internal Calendar" _
And Not ws.Name = "External Calendar" Then
unusedRow = external.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row 'if you want to find last filled row i suggest to change to: external.cells(external.rows.count, [column number]).end(xlup).row
ws.Range("A1").AutoFilter Field:=6, Criteria1:="=Both", _
Operator:=xlOr, Criteria2:="=External"
ws.UsedRange.Copy
external.Cells(unusedRow, 1).PasteSpecial xlPasteAll 'paste into "A" column
End If
Next ws
End Sub

Copy and Past Transpose of a Range

Sub CommandButton2_Click()
Dim Report As Workbook
Dim book As Workbook: Set book = ThisWorkbook
Dim myfilename As String
Dim lRow As Long
Set Report = Workbooks.Open("S:\HR Compensation\Christapher Martin\Tellurian
Inc Job Pricing\Job Families and Competencies - Report.xlsm")
lRow = book.Sheets(2).Cells(Rows.Count, 3).End(xlUp).Row
book.Sheets(2).Range(Cells(8, 3), Cells(lRow, 3)).Copy
Report.Sheets(1).Range("B2").PasteSpecial Transpose:=True
End Sub
I'm trying to get this to work so it will copy and paste entered data without having to manually change the code every time new info is added because this will eventually load a bunch of info into a "Report" per se, so manually copy pasting data or changing the code won't be an option. I know the issue is with the lRow in the Copy line of the code, I'm just not sure what it is.
Using With
Simplified, everything starting with a dot (".") is referring to the
object in the With statement.
In your version without the With statement, what ever starts with a
dot (".") should have been preceded by book.Sheets(2)
Not sure if 'Tellurian Inc' is with or without the SPACE. Correct
if necessary.
The Code
Sub CommandButton2_Click()
Dim Report As Workbook
Dim lRow As Long
Set Report = Workbooks.Open("S:\HR Compensation\Christapher Martin\" _
& "Tellurian Inc Job Pricing\Job Families and Competencies " _
& "- Report.xlsm")
With ThisWorkbook.Sheets(2)
lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(8, 3), .Cells(lRow, 3)).Copy
End With
Report.Sheets(1).Range("B2").PasteSpecial Transpose:=True
Application.CutCopyMode = False
End Sub
EDIT:
You can do the same thing with the other worksheet.
With .Parent you are referring to a higher level object e.g. you want
to save the changes and close the workbook, but you are referring to
Sheets(1) now, which you cannot close, so with .Parent you refer to the higher level which is the workbook (Report). For safety reasons I left it commented.
Sub CommandButton2_Click()
Dim Report As Workbook
Dim lRow As Long
Set Report = Workbooks.Open("S:\HR Compensation\Christapher Martin\" _
& "Tellurian Inc Job Pricing\Job Families and Competencies " _
& "- Report.xlsm")
With ThisWorkbook.Sheets(2)
lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(8, 3), .Cells(lRow, 3)).Copy
End With
With Report.Sheets(1)
.Range("B2").PasteSpecial Transpose:=True
'.Parent.Close True ' Save changes and close workbook.
End With
Application.CutCopyMode = False
End Sub

deleting excel tabs doesn't reduce file size

In an effort to reduce a 60MB excel file I deleted half the tabs, and many of the formulas on the remaining tabs.
The result didn't budge the overall filesize. Perhaps (as in access) there's a function/addin/? which will compress or recover the space?
I tried to export the tabs to a new file, however, most of the tabs have tables and so is impossible.
btw, the file is already in .XLSB format.
thank you,
-R
Here is my liposuction code I wrote years ago, it will do formulas, text and pics, doesn't do charts currently but you can see how it handles pics and add that in easily enough.
Sub LipoSuction2()
'Written by Daniel Donoghue 18/8/2009
'The purpose of this code is to offer an alternative to the original Liposuction code written by JBeaucaire for the MrExcel forums www.mrexcel.com
Dim ws As Worksheet
Dim CurrentSheet As String
Dim OldSheet As String
Dim Col As Long
Dim r As Long
Dim BottomrRow As Long
Dim EndCol As Long
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Dim Pic As Object
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
For Each ws In Worksheets
ws.Activate
'Put the sheets in a variable to make it easy to go back and forth
CurrentSheet = ws.Name
'Rename the sheet to its name with TRMFAT at the end
OldSheet = CurrentSheet & "TRMFAT"
ws.Name = OldSheet
'Add a new sheet and call it the original sheets name
Sheets.Add
ActiveSheet.Name = CurrentSheet
Sheets(OldSheet).Activate
'Find the bottom cell of data on each column and find the further row
For Col = 1 To Columns.Count 'Find the REAL bottom row
If Cells(Rows.Count, Col).End(xlUp).Row > BottomRow Then
BottomRow = Cells(Rows.Count, Col).End(xlUp).Row
End If
Next
'Find the end cell of data on each row that has data and find the furthest one
For r = 1 To BottomRow 'Find the REAL most right column
If Cells(r, Columns.Count).End(xlToLeft).Column > EndCol Then
EndCol = Cells(r, Columns.Count).End(xlToLeft).Column
End If
Next
'Copy the REAL set of data
Range(Cells(1, 1), Cells(BottomRow, EndCol)).Copy
Sheets(CurrentSheet).Activate
'Paste everything
Range("A1").PasteSpecial xlPasteAll
'Paste Column Widths
Range("A1").PasteSpecial xlPasteColumnWidths
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Sheets(OldSheet).Activate
For Each Pic In ActiveSheet.Pictures
Pic.Copy
Sheets(CurrentSheet).Paste
Sheets(CurrentSheet).Pictures(Pic.Index).Top = Pic.Top
Sheets(CurrentSheet).Pictures(Pic.Index).Left = Pic.Left
Next
Sheets(CurrentSheet).Activate
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
'Reset the variable for the next sheet
BottomRow = 0
EndCol = 0
Next
'Excel will automatically replace the sheet references for you on your formulas, the below part puts them back
'This is done with a simple reaplce, replacing TRMFAT with nothing
For Each ws In Worksheets
ws.Activate
Cells.Replace "TRMFAT", ""
Next
'Poll through the sheets and delete the original bloated sheets
For Each ws In Worksheets
If Not Len(Replace(ws.Name, "TRMFAT", "")) = Len(ws.Name) Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
End Sub

run macro on AutoFilter and show data in new sheet

Actually what i want to do , i have following data With Auto Filtering ,
-> I want to create new sheet for each unique Name selected from filtering .i.e. if John and Alex are selected then 2 new sheets should be created one for John and second for Alex , and each of them show own data (Name + No + R). When Next time if master sheet get updated then news data should be appended when i run macro. i'm using following code but its not working 100%.
Sub mycar()
x = 2
Do While Cells(x, 1) <> ""
If Cells(x, 1) = "John" Then
Worksheets("Sheet1").Rows(x).Copy
Worksheets("Sheet2").Activate
eRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(eRow)
End If
Worksheets("Sheet1").Activate
x = x + 1
Loop
End Sub
-> Here it copy only single data Written in the quotes.
-> Second time if i run this code , it is appending same data again with new data.
Help me to avoid this mistakes.
Thank you.
As discussed there is other possibility to set filter parameters in Array in procedure. The code would look like this one:
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter
Dim myArr As Variant
myArr = Array("John", "max")
Range("a1").AutoFilter
Dim i As Long
For i = 0 To UBound(myArr)
shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
Operator:=xlAnd
On Error Resume Next
Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i)
Err.Clear
End If
Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter
End Sub
Substitute Worksheets("Sheet1").Rows(x).Copy by Worksheets("Sheet1").Rows(x).EntireRow.Copy
And clear the destination worksheet before adding information.
I do quite similar exercise quite often. Therefore I provide full possible solution with some comments inside the code. It works for all unique values in column A and creates (if not exists) sheet with appropriate name equals to filter parameters.
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
'get unique values based on Excel features
'i guess some will not like it but I do :)
Range("a1").AutoFilter
Range("A1").CurrentRegion.Columns(1).Copy Range("ww1")
Range("ww1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'be sure that range where you copy (like ww1) is empty range around
Dim myArr As Variant
myArr = Range(Range("ww2"), Range("ww2").End(xlDown))
Range("ww1").CurrentRegion.ClearContents 'some cleaning
Range("a1").AutoFilter '
Dim i As Long
For i = 1 To UBound(myArr, 1)
ActiveSheet.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i, 1), _
Operator:=xlAnd
On Error Resume Next
'this is for two reason- to check if appropriate sheet exists, if so to clean top area
'if you need to append you would comment this line
Sheets(myArr(i, 1)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
'if you need to append only you would need to set range-to-copy a bit different
Range("A1").CurrentRegion.Copy Sheets(myArr(i, 1)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i, 1)
Err.Clear
End If
Next i
End Sub
This could not fully meet your requirements but could be a complete solution to improve accordingly.
Heading ##Below code is as per your requirement. Modify it based upon your requirement.
Private Sub Worksheet_Calculate()
Dim x As Integer
Dim rnge As Integer
x = Range(Selection, Selection.End(xlDown)).Count
rnge = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
If Range("E1").Value > rnge Then
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Paste
End If
End Sub

Moving rows based on column values

I need to scan through all of the rows in the "Master" worksheet, find any cells with the value "Shipped" in the column "Status", then cut and paste each entire row to another sheet. The pasted rows need to be placed after the last row also.
I found this post (pasted below) which I slightly modified to delete rows successfully. But I can not figure out how to move rows instead. Should I try an entirely new method?
Sub DeleteRows()
Dim rng As Range
Dim counter As Long, numRows as long
With ActiveSheet
Set rng = Application.Intersect(.UsedRange, .Range("C:C"))
End With
numRows = rng.Rows.Count
For counter = numRows to 1 Step -1
If Not rng.Cells(counter) Like "AA*" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
End Sub
I do not know VBA. I only kind of understand it because of my brief programming history. I hope that is okay and thank you for any help.
There's a couple of ways you could do it, can you add a filter to the top columns, filter by the value of 'Shipped'? Does it need to be copy and pasted into a new sheet?
It's not the most concise code but it might work
sub Shipped_filter()
dim wsSheet as worksheet
dim wsOutputSheet as worksheet
dim BottomRow as integer
Set wsSheet = worksheets("Sheet1") 'change to the sheet name
set wsOutputSheet = worksheets("Sheet2") 'change to the sheet name
'*****************************
'* Delete old data on Sheet2 *
'*****************************
wsoutputsheet.activate
Activesheet.cells.clearall
wsSheet.range("A1").select
selection.autofilter
BottomRow = wsSheet.range("A90000").end(xlup).row ' or another column you guarantee will always have a value
activesheet.range("$A$1:$Z$"&BottomRow).AutoFilter field:=1, Criteria1:="Shipped" ' change field to whatever column number Status is in
'********************************
'* Error trap in case no update *
'********************************
if activesheet.range("A90000").end(xlup).row = 1 then
msgbox("Nothing to ship")
exit sub
end if
wsSheet.range("A1:Z"&Bottomrow).select
selection.copy
wsOutputSheet.range("A1").select
selection.pastespecial Paste:=xlpastevalues
application.cutcopymode = false
msgbox('update complete')
end sub
I haven't tried it so it might need updating
I ended up combining the code I was originally using (found here) with an AutoFilter macro (found here). This is probably not the most efficient way but it works for now. If anyone knows how I can use only the For Loop or only the AutoFilter method that would be great. Here is my code. Any edits I should make?
Sub DeleteShipped()
Dim lastrow As Long
Dim rng As Range
Dim counter As Long, numRows As Long
With Sheets("Master")
'Check for any rows with shipped
If .Range("R:R").Find("Shipped", , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No shipped plates found. ", , "No Rows Moved": Exit Sub
Else
Application.ScreenUpdating = False
'Copy and paste rows
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Worksheets("ShippedBackup").Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A1:U" & lastrow).AutoFilter field:=18, Criteria1:="Shipped"
.Range("A2:U" & lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("ShippedBackup").Range("A" & lastrow2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.ShowAllData
'Delete rows with shipped status
Set rng = Application.Intersect(.UsedRange, .Range("R:R"))
numRows = rng.Rows.Count
For counter = numRows To 1 Step -1
If rng.Cells(counter) Like "Shipped" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
MsgBox "All shipped records have been moved to the ""ShippedBackup"" worksheet.", , "Backup Complete"
End If
End With
Hope it helps someone!

Resources