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
Bookmarks