Excel, comparing two sets of two rows

Sub CompareExpendables()
'This macro checks all of the cells in one column on sheet 1(expendables)
'against one column on sheet 2(on hand inventory) and creates a new sheet
'showing all of the items that appear on both.
'Credit to Kioskea users for assisting in the creation of this macro

Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh1row As Integer
    Dim sh2row As Integer
    Dim sh1col As Integer
    Dim sh2col As Integer
    Dim rng1ct As Range
    Dim rng2ct As Range
    Dim row1 As Range
    Dim row2 As Range
    Dim lastRow As Long
    Dim i As Integer
        
    Set sh1 = ActiveWorkbook.Sheets(1)
    Set sh2 = ActiveWorkbook.Sheets(2)
    sh1row = sh1.Range("a" & Rows.Count).End(xlUp).Row
    sh1col = sh1.Range("a" & Columns.Count).End(xlToLeft).Column
    Set rng1ct = sh1.Range("a2").Resize(sh1row, sh1col)
    sh2row = sh2.Range("b" & Rows.Count).End(xlUp).Row
    sh2col = sh2.Range("b" & Columns.Count).End(xlToLeft).Column
    Set rng2ct = sh2.Range("b3").Resize(sh2row, sh2col)
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    sh2.Range("a2:l2").Copy Destination:=Worksheets(3).Range("a1:l1")
       
     With Worksheets(3)
        .AutoFilterMode = False
        .Range("A1:L1").AutoFilter
    End With
    
    For Each row1 In rng1ct
        For Each row2 In rng2ct
            If row2 = row1 AND sh1.Range("D" & Rows.count) = sh2.Range("D" & Rows.count)_ Then
                row2.EntireRow.Copy Destination:=Worksheets(3).Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next row2
    Next row1
    
    lastRow = Range("K" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow
        If Range("K" & i) = "" Then Exit For
        If Range("K" & i).Value = 0 Then
        Range("K" & i).EntireRow.Delete
        i = i - 1
        End If
    Next i
        
    Worksheets(3).Range("A2:L2").Select
        Selection.EntireColumn.AutoFit
    Worksheets(3).Columns("E:H").ColumnWidth = 0
    
End Sub