MACRO to DELETE rows if Values in Row A Sheet2, do NOT match main sheet (Sheet1)

[surkdidat]

I need a MACRO (as I have a spreadsheet with 50k lines+ on (Sheet 1, which has data from Column A to AC (some rows may have blank cells anywhere between the two columns.

There are multiple rows that have the same reference number

(Main Sheet - Sheet1)	Column A	Column B	Column C	.... Column AC
Row 1	ID	Data_1	Data_2	Data_27
Row 2	10001	efaf	sf	fssdf
Row 3	10001	dfsads	tyrttfg	gfdgfsg
Row 4	10001	sdfs	rutr	f
Row 5	10002	dfssdf	ffsdagh	gas
Row 6	10003	wrefrf	fefasf
Row 7	10003	ffae
Row 8	10004	fewaef	sadfadsf	asfdasfd

In Sheet2

Sheet2
ID (Column A)
10001
10004

So, the MACRO runs, and deletes any row whos value is NOT 10001 or 10004
(Deletes Rows 5 6 7 (10002 and 10003 values)

 

[DanteAmor]

How about:

Sub deleterows()
  Dim dic As Object
  Dim sh1 As Worksheet
  Dim i As Long, j As Long, k As Long
  Dim a As Variant, b As Variant, c As Variant
  
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  a = sh1.Range("A2:AC" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  b = Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = Empty
  Next
  
  For i = 1 To UBound(a, 1)
    If dic.exists(a(i, 1)) Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        c(k, j) = a(i, j)
      Next
    End If
  Next
  
  sh1.Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = c
End Sub

 

[kevin9999]

You've got a great solution from @DanteAmor , but just to show an alternative way which works just as quickly (tested on 100k rows at 1.5~ seconds)

Option Explicit
Sub FastDelete()
    Dim arrIn, arrOut, arrTest
    Dim i As Long, j As Long, lr1 As Long, lr2 As Long
    Application.ScreenUpdating = False
    
    lr1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    lr2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row    
    arrIn = Sheet1.Range("A2:AC" & lr1)
    arrTest = Sheet2.Range("A2:A" & lr2)
    ReDim arrOut(1 To UBound(arrIn), 1 To 1)
    
    For i = 1 To UBound(arrIn)
        For j = 1 To UBound(arrTest)
            If arrIn(i, 1) = arrTest(j, 1) Then
            arrOut(i, 1) = 1
            End If
        Next j
    Next i
    
    Sheet1.Range("AD2").Resize(UBound(arrOut)) = arrOut   
    Sheet1.Range("A2:AD" & lr1).Sort Key1:=Sheet1.Range("AD2"), order1:=xlDescending, Header:=xlNo
    
    With Sheet1.Range("AD1").CurrentRegion
        .AutoFilter 30, "<>" & 1
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With    
    Sheet1.Range("AD:AD").ClearContents
    
    Application.ScreenUpdating = True
End Sub

 

[kevin9999]

Slightly faster version here:

Option Explicit
Sub FastDelete()
    Dim arrIn, arrOut, arrTest
    Dim i As Long, j As Long, lr1 As Long, lr2 As Long, topR As Long
    Application.ScreenUpdating = False
    
    lr1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    lr2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
    
    arrIn = Sheet1.Range("A2:AC" & lr1)
    arrTest = Sheet2.Range("A2:A" & lr2)

    ReDim arrOut(1 To UBound(arrIn), 1 To 1)
    
    For i = 1 To UBound(arrIn)
        For j = 1 To UBound(arrTest)
            If arrIn(i, 1) = arrTest(j, 1) Then
            arrOut(i, 1) = 1
            End If
        Next j
    Next i
    
    Sheet1.Range("AD2").Resize(UBound(arrOut)) = arrOut
    
    Sheet1.Range("A2:AD" & lr1).Sort Key1:=Sheet1.Range("AD2"), order1:=xlDescending, Header:=xlNo
    topR = Sheet1.Cells(Rows.Count, 30).End(xlUp).Row + 1
    
    Sheet1.Rows(topR & ":" & lr1).EntireRow.Delete
    Sheet1.Range("AD:AD").ClearContents    
    Application.ScreenUpdating = True
End Sub

 

[surkdidat]

Apologies all, I have not had a chance to test and put this into action due to a couple of things going on my end. I really appreciate everyone's help and will get a chance on Monday or Tuesday to put this into my spreadsheets. I will come back then and appreciate more when everything is better my end and I get what I need from your solutions!
Thanks again!