Question: How can I copy cells B through Y for all rows based on a unique ID in Column A? I can't copy the entire row, just that range.
screenshot with music data
My method: I copy the sheet > filter > copy visible cells > delete visible cells > move to next filter entry and repeat.
The problem: Some maps (esp. small ones) don't copy. I'd also like a simpler way to do it. I made this file for me just to concat XML together. But now several Mac users are using it and having more problems due to this part of the code.
Sub mapmaker()
Dim LR As Long
Dim Rng As Range
Dim mws As Worksheet
Dim c As Range, i As Long
Dim lastrow As Long, nextrow As Long
Dim cn As Range, rn As Range
Dim output As String
' duplicate sheet with data to copy, set range, see if range contains data
Set rn = Sheets("XML").Range("DR1:DR505")
Application.ScreenUpdating = False
Sheets("Master").Copy After:=Sheets("Master")
ActiveSheet.Name = "MstrCpy"
Sheets("MstrCpy").Select
Range("A1").Select
Set Rng = Worksheets("MstrCpy").Range("A2:A1000")
Set mws = Worksheets("MstrCpy")
If WorksheetFunction.CountA(Rng) < 1 Then Exit Sub
With mws
' count number of entries
i = WorksheetFunction.CountA(Rng)
'turn off any previous filters
If .AutoFilterMode = True Then .AutoFilterMode = False
'loop through cells, filter and copy results
For Each c In .Range("A2:A" & i)
Sheets("XML").Range("A8:X1000").ClearContents
Sheets("MstrCpy").Select
nextrow = Sheets("MstrCpy").Cells(Rows.Count, "A").End(xlUp).Row
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value
.Range("B2:Y" & lastrow).SpecialCells(xlCellTypeVisible).Copy Sheets("XML").Range("A8")
.Range("A2").Copy Sheets("XML").Range("B4")
.Range("B2:Y" & lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Sheets("MstrCpy").Select
.AutoFilterMode = False
Sheets("XML").Select
output1 = Range("BB2").Value
output2 = Range("BB3").Value
Open output1 For Output As #1
For Each cell In rn
Print #1, cell.Value & Chr(10)
Next
Close
Name output1 As output2
Sheets("MstrCpy").Select
Next c
'turn off filtering
.AutoFilterMode = False
End With
Application.DisplayAlerts = False
Sheets("MstrCpy").Delete
Sheets("Master").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I tend to write things less backwards now. But I don't know VBA well enough to figure this out and my attempts have failed. The similar questions I've seen don't seem to be useful here. Any help would be greatly appreciated and would aid more people than just myself. Thank you!
-Sean
Related
I am working on one scenario where I have two sheets. Sheet1 is the master sheet and sheet2 which I am creating.
Column1 of Sheet1 is Object which has duplicate objects as well. So, what I have done is I have created a macro which will produce the unique Objects and will paste it in sheet2.
Now, from Sheet2, each of the objects should be matched with Sheet1 column1 and based on the matching results, it should also count the corresponding entries from other columns in sheet1 to sheet2.
Below are the snapshots of my two sheets
Sheet1
Sheet2
here is my macro code which will first copy and paste the unique objects from sheet1 to sheet2 Column1.
Sub UniqueObj()
Dim Sh1 As Worksheet
Dim Rng As Range
Dim Sh2 As Worksheet
Set Sh1 = Worksheets("Sheet1")
Set Rng = Sh1.Range("A1:A" & Sh1.Range("A65536").End(xlUp).Row)
Set Sh2 = Worksheets("Sheet1")
Rng.Cells(1, 1).Copy Sh2.Cells(1, 1)
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True
End Sub
But, I am unable to move forward from there. I am pretty new and any help would be very greatful.
Thanks
If I'm understanding what you want correctly, you're just counting matching columns from Sheet1 where the value in the corresponding column isn't blank? If so this should do the trick.
Option Explicit
Sub GetStuffFromSheet1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim x As Long
'turn on error handling
On Error GoTo error_handler
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'determine last row with data in sheet 1
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
'determine last row with data in sheet 2
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
'define columns in sheet 1
Const objCol1 As Long = 1
Const rProdCol1 As Long = 3
Const keysCol1 As Long = 4
Const addKeysCol1 As Long = 5
'define columns in sheet 2
Const objCol2 As Long = 1
Const rProdCol2 As Long = 2
Const keysCol2 As Long = 3
Const addKeysCol2 As Long = 4
'turn off screen updating + calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'loop through all rows of sheet 2
For x = 2 To lastRow2
'formula counts # of cells with matching obj where value isn't blank
ws2.Cells(x, rProdCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(rProdCol1), "<>" & "")
ws2.Cells(x, keysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(keysCol1), "<>" & "")
ws2.Cells(x, addKeysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(addKeysCol1), "<>" & "")
Next x
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
error_handler:
'display error message
MsgBox "Error # " & Err.Number & " - " & Err.Description, vbCritical, "Error"
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
In case a non VBA solution works for you, you can resume your data with a Pivot Table, take field Object into rows section and rest of fields into values section (choose Count)
This returns the exact output you are looking for. Easy to update and easy to create.
In case you want a VBA solution, because your design is tabular and you are counting values, you can use CONSOLIDATE:
Consolidate data in multiple worksheets
'change K1 with cell where to paste data.
Range("K1").Consolidate Range("A1").CurrentRegion.Address(True, True, xlR1C1, True), xlCount, True, True, False
'we delete column relation type and column value. This columns depends on where you paste data, in this case, K1
Range("L:L,P:P").Delete Shift:=xlToLeft
After executing code i get this:
Hope this helps
I have an API call that pulls data relating to 34 individual sites. Each site has a varying number of assets within it, each with a unique identifier.
I am trying to write a macro that will copy and paste the data for specific sites into their own individual worksheet within the file. The basic concept of this I am familiar with but I am struggling with the ranges I need to specify.
So basically, I need the macro to work its way down Column A of the sheet called Raw Data and identify any rows where the Site name (Value in column A) matches one of the Sheet names. It should then copy the Rows from A to H with that site name and paste into the respective site sheet in rows A to H.
The values in Column A will always match one of the other sheets in the workbook.
Example image that might help explain a bit better:
Apologies in advance if my explanation is not very clear. I have very limited experience using macros so I am not sure if my way of explaining what I want to achieve is understandable or if at all possible.
I am very keen to learn however and any guidance you fine folk could offer would be very much appreciated.
Welcome!
Try this one
Function ChkSheet(SheetName As String) As Boolean
For i = 1 To Worksheets.Count
If Worksheets(i).Name = SheetName Then
ChkSheet = True
Exit Function
End If
Next
ChkSheet = False
End Function
Sub test()
Dim i, j, k As Long
Dim wsRaw As Worksheet
Dim Aux As String
Set wsRaw = Worksheets("Raw Data")
For i = 1 To wsRaw.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
If ChkSheet(wsRaw.Cells(i, 1).Value2) Then
Aux = wsRaw.Cells(i, 1).Value2
k = Worksheets(Aux).Range("A:A").SpecialCells(xlCellTypeLastCell).Row + 1
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
Else
Worksheets.Add.Name = wsRaw.Cells(i, 1).Value2
Aux = wsRaw.Cells(i, 1).Value2
k = 2
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
End If
Next
End Sub
So the Function ChkSheet will check if the sheet exist (you don´t need to create them) and the procedure test will follow all the items that you have in your "Raw Data" worksheet and it will copy to the last used row of every sheet.
And please, even for a newbie, google, read, get some information and when you get stacked, ask for help. This forum is not for giving solutions with not effort.
Good morning all,
David, thanks very much for your help with this. I really didn't want you to think I was trying to get someone to give me the answer and I had tried a few other things before asking the question, but I neglected to show any evidence of my workings. Rookie mistake and I apologise for this.
Having done a bit more research online and with a good dollop of help from a much more experienced colleague I have got the below code using advance filter which works perfectly for what I need.
I thought I would share it here in case it is of any use to others in the future.
Option Explicit
Dim RawDataCol As String
Dim ListCol As String
Dim AdvRng As String
Dim RawDataRng As String
Dim SiteAbrRng As String
Dim ShiftCols As String
Private Sub SetParameters()
'Cell Address where RawData is pasted to each of the site sheets
RawDataCol = "A2"
'Column where the Unique List is cleared and pasted
ListCol = "L"
'Advanced Filter Range
AdvRng = "A1:K2"
'Pasted Raw Data Columns on each sheet
RawDataRng = "A2:K"
'Site Abr gets pasted to the address during loop
SiteAbrRng = "A2"
'Range that gets deleted after pasting Raw Data to each sheet
ShiftCols = "A2:K2"
End Sub
Sub CopyDataToSheets()
On Error GoTo ErrorHandler
AppSettings (True)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim wbk As Workbook
Dim sht_RawData As Worksheet, sht_target As Worksheet, sht_AdvancedFilter As Worksheet, sht_TurbineData As Worksheet
Dim tbl_RawData As ListObject
Dim LastRow1 As Long, LastRow2 As Long, UniqueListCount As Long
Dim MyArr As Variant
Dim ArrTest As Boolean
Dim x As Long, AdvRowNo As Long
Set wbk = ThisWorkbook
SetParameters
Set sht_RawData = wbk.Worksheets("Raw Data")
Set sht_AdvancedFilter = wbk.Worksheets("Advanced Filter")
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_RawData = sht_RawData.ListObjects("_00")
'clear unqie list of SiteAbr
With sht_TurbineData
LastRow1 = .Cells(Rows.Count, 12).End(xlUp).Row
If LastRow1 > 1 Then
'sht_TurbineData.Range("L1:L" & LastRow1).ClearContents
sht_TurbineData.Range(ListCol & 1 & ":" & ListCol & LastRow1).ClearContents
End If
End With
'Copy Unqiue list of SiteAbr to Turbie Data Sheet
tbl_RawData.Range.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=sht_TurbineData.Range(ListCol & 1), _
Unique:=True
LastRow1 = sht_TurbineData.Cells(Rows.Count, sht_TurbineData.Range(ListCol & 1).Column).End(xlUp).Row
'Sort Unique List
sht_TurbineData.Range("L1:L" & LastRow1).Sort _
Key1:=sht_TurbineData.Range("L1"), _
Order1:=xlAscending, _
Header:=xlYes
'Load unique site Abr to array
With sht_TurbineData
'MyArr = Application.Transpose(.Range("L2:L" & LastRow1))
MyArr = Application.Transpose(.Range(ListCol & 2 & ":" & ListCol & LastRow1))
UniqueListCount = LastRow1 - 1
End With
'Test Array conditions for 0 items or 1 item
ArrTest = IsArray(MyArr)
If UniqueListCount = 1 Then
MyArr = Array(MyArr)
ElseIf UniqueListCount = 0 Then
GoTo ExitSub
End If
For x = LBound(MyArr) To UBound(MyArr)
Set sht_target = wbk.Worksheets(MyArr(x))
With sht_target
'Find the last non blank row of the target paste sheet
LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
'Clear contents if the Last Row is not the header row
If LastRow2 > 1 Then
.Range(RawDataRng & LastRow2).ClearContents
End If
sht_AdvancedFilter.Range(SiteAbrRng) = MyArr(x)
'Filter Source Data and Copy to Target Sheet
tbl_RawData.Range.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=sht_AdvancedFilter.Range(AdvRng), _
CopyToRange:=.Range(RawDataCol), _
Unique:=False
'Remove the first row as this contains the headers
.Range(ShiftCols).Delete xlShiftUp
End With
Next x
ExitSub:
SecondsElapsed = Round(Timer - StartTime, 3)
AppSettings (False)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
ErrorHandler:
MsgBox (Err.Number & vbNewLine & Err.Description)
GoTo ExitSub
End Sub
Sub ClearAllSheets()
Dim tbl_SiteList As ListObject
Dim wbk As Workbook
Dim sht_target As Worksheet, sht_TurbineData As Worksheet
Dim MyArray As Variant
Dim x As Long, LastRow As Long
Set wbk = ThisWorkbook
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_SiteList = sht_TurbineData.ListObjects("SiteList")
SetParameters
MyArray = Application.Transpose(tbl_SiteList.DataBodyRange)
For x = LBound(MyArray) To UBound(MyArray)
Set sht_target = wbk.Worksheets(MyArray(x))
LastRow = sht_target.Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
sht_target.Range("A2:K" & LastRow).ClearContents
End If
Next x
End Sub
Private Sub AppSettings(Opt As Boolean)
If Opt = True Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ElseIf Opt = False Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Thanks again to all who answered and especially to you David. Although I have only used the basic principles from what you offered, it was extremely useful to help me understand what I needed to do in order to get the data to copy into the correct sheets.
Many thanks,
MrChrisP
I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub
I have an excel table with rows of data. The column J contains various descriptions of goods. I need to search all the rows in this column for the word LATEX and when it is found, copy ONLY this word to the column A on the same sheet on the same row. I was trying to find a solution and came up with this macro using Autofilter, but it is not working properly. Can you please help me?
Sub FilterAndCopy()
Dim dataWs As Worksheet
Dim copyWs As Worksheet
Dim totRows As Long
Dim lastRow As Long
Set dataWs = Worksheets("Massiv")
Set copyWs = Worksheets("Massiv")
With dataWs
.AutoFilterMode = False
With .Range("J:J")
.AutoFilter Field:=1, Criteria1:="LATEX"
End With
End With
totRows = dataWs.Range("J:J").Rows.count
lastRow = dataWs.Range("J" & totRows).End(xlUp).Row
dataWs.Range("J:J" & lastRow).Copy
copyWs.Range("A6").PasteSpecial Paste:=xlPasteValues
dataWs.AutoFilterMode = False
With the following changes, your code should work. I've noted the changes in the comments in the code.
With dataWs
.AutoFilterMode = False
With .Range("J:J")
'Use wildcard to search for word LATEX within contents of column J cells
.AutoFilter Field:=1, Criteria1:="*LATEX*"
End With
End With
totRows = dataWs.Range("J:J").Rows.Count
lastRow = dataWs.Range("J" & totRows).End(xlUp).Row
'After filtering, select the visible cells in column A...
Set rng = dataWs.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible)
'... and set their values to "LATEX"
rng.Value = "LATEX"
dataWs.AutoFilterMode = False
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!