Comparing adjacent columns from 2 worksheets

Its sooo very close...there has to be someone here with the missing puzzle piece

How its supposed to work...
Compare each sheet1's column C to sheet2's column C.
If any data matches...compare each sheet's corresponding column D
If column D also matches...copy entire row of data to new sheet.

But what its doing...
If it matches column C's data, it will copy the entire row from sheet2 without comparing column D
Example:
sheet1
C | D
1 | 3
2 | 5
3 | 9

sheet2
C | D
1 | 4
2 | 3
3 | 9

output should only include 3 9

    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
            
    ' Set current work sheets to variables
    Set sh1 = ActiveWorkbook.Sheets(1)
    Set sh2 = ActiveWorkbook.Sheets(2)
    
    'Define size of searchable area in the first sheet
    sh1row = sh1.Range("c" & Rows.Count).End(xlUp).Row
    sh1col = sh1.Range("c" & Columns.Count).End(xlToLeft).Column
    Set rng1ct = sh1.Range("c2").Resize(sh1row, sh1col)
    
    'Define size of searchable area in the second sheet
    sh2row = sh2.Range("c" & Rows.Count).End(xlUp).Row
    sh2col = sh2.Range("c" & Columns.Count).End(xlToLeft).Column
    Set rng2ct = sh2.Range("c2").Resize(sh2row, sh2col)
    
    'Create third sheet for data display and copies headers
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    sh2.Range("a1:d1").Copy Destination:=Worksheets(3).Range("a1:d1")
       
    'Enables auto filter on newly created columns
    With Worksheets(3)
        .AutoFilterMode = False
        .Range("A1:D1").AutoFilter
    End With
    
    'Checks each line in the second sheet against each line in the first sheet
    'If column "C" in each row match, check against column "D".  If both match
    'copy entire row to new sheet
    For Each row1 In rng1ct
        For Each row2 In rng2ct
            If row2 = row1 And sh2.Range("D" & Rows.Count).Value = sh1.Range("D" & Rows.Count).Value Then
                row2.EntireRow.Copy Destination:=Worksheets(3).Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next row2
    Next row1
    
    'Look at third sheet after all data is copied, ensure no duplicates are
    'encountered
    ActiveSheet.Range("$A$1:$D$1606").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
        Header:=xlYes
    
    'Adjusts column width to autofit
    Worksheets(3).Range("A2:D2").Select
        Selection.EntireColumn.AutoFit
        
End Sub

Maybe:

Sub Witebutter()
Dim lr As Long
Dim rcell As Range

Application.ScreenUpdating = False

lr = Cells(Rows.Count, 1).End(xlUp).Row

'On sheet1

Columns("C:C").Insert SHIFT:=xlToRight

With Range("D2:D" & lr)

    .Formula = "=VLOOKUP(C2,Sheet2!$C$2:$C$1000,1,FALSE)"
    .Value = .Value
    .Replace What:="#N/A", Replacement:="", LookAt:=xlWhole
    
End With

Columns("F:F").Insert SHIFT:=xlToRight

With Range("F2:F" & lr)

    .Formula = "=VLOOKUP(E2,Sheet2!$D$2:$D$1000,1,FALSE)"
    .Value = .Value
    .Replace What:="#N/A", Replacement:="", LookAt:=xlWhole
    
End With

For Each rcell In Range("D2:D" & lr)

    If rcell.Value <> "" Then
    
        If rcell.Offset(, 2) <> "" Then
        
            rcell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2)
            
        End If
        
    End If
    
Next rcell

Application.ScreenUpdating = True

End Sub