Thread: VBA cut from sheet 1 with multiple criteria onsheet 2,paste to next blank row sheet3

I have been trying to solve this for days (boss is not to happy)

I have multiple sheets in a workbook, I currently use a multiple criteria look up from 1 sheet to delete entire rows from another sheet.

now i need to do much the same except i have to cut and paste.

Sheet 1 sheet 2 sheet 3
a b a a b

2 4700 4700 2 4700
1 22 4701 3 4798
5 5001 4702
3 4798 4703 delete above from sheet 1
7 2205 4704
4705
etc to 4799


here is the code im trying to use, it just wont copy paste and then delete!

Sub cutpaste()
    Dim rng As Range
    Dim cell As Range
    Dim CriteriaRng As Range
    Dim CalcMode As Long
    Dim My_Range As Range
 
    Set My_Range = Worksheets("monday hillsborough 1300").Range("A10:h" & lastrow(Worksheets("monday hillsborough 1300")))
    My_Range.Parent.Select
 
 
 
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    With Sheets("qa-qos")
        Set CriteriaRng = .Range("a1", .Cells(Rows.Count, "a").End(xlUp))
    End With
    'Loop through the cells in the Criteria range
    For Each cell In CriteriaRng
        With Sheets("Monday Hillsborough 1300")
            'Firstly, remove the AutoFilter
            .AutoFilterMode = False
            'Apply the filter
            .Range("c1:c" & .Rows.Count).AutoFilter Field:=3, Criteria1:=cell.Value
 
My_Range.Parent.AutoFilter.Range.Copy
With Sheets("monday qa-qos")
AutoFilter.Range.Paste
 
            Application.CutCopyMode = False
            .Select
        End With
 
            With .AutoFilter.Range
                Set rng = Nothing
                On Error Resume Next
                Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                          .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng Is Nothing Then rng.EntireRow.Delete
            End With
            'Remove the AutoFilter
            .AutoFilterMode = False
        End With
    Next cell
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Subit seems so simple but im not an expert. Please help i am way past a deadline.

Thank you in advance!!
Kevinsnewmatrix

that sounds great...need to delete, but where would i put it?? and will it loop to get all the cells in the criteriarange? (a1:a)

ok i see...sheesh Im a novice still so......Thanks..Ill let you know how it goes!!!!!

Thank you!!