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
Bookmarks