Hello Boraxx,
This macro will copy the rows if the cells in column "J" or "K" meet the criteria. The empty rows are deleted and the rows shifted up. The copy data starts in cell "A1" on the sheet "MidRange".
Sub Macro1()
Dim Data() As Variant
Dim DstWks As Worksheet
Dim I As Long
Dim LastRow As Long
Dim NextRow As Long
Dim Rng As Range
Dim RngEnd As Range
Set Rng = Range(Columns("J"), Columns("K"))
Set DstWks = Worksheets("MidRange")
Set RngEnd = Rng.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False)
LastRow = RngEnd.Row
NextRow = 1
Set Rng = Range(Cells(1, "J"), Cells(LastRow, "K"))
ReDim Data(1 To Rng.Rows.Count)
ReDim Data(Rng.Rows.Count, 1 To 2)
Data = Rng.Value
For I = 1 To UBound(Data, 1)
If (Data(I, 1) >= 60 And Data(I, 1) <= 80) Or Data(I, 2) = "Closeloss" Then
Rng.Rows(I).EntireRow.Copy DstWks.Cells(NextRow, "A")
NextRow = NextRow + 1
Data(I, 2) = Empty
End If
Next I
Rng.Value = Data
On Error Resume Next
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Bookmarks