Sub copyp()
With Worksheets("TIMESPAN")
x = .Range("ac6").CurrentRegion.Value
End With
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = 1
With dic
For i = 1 To UBound(x, 1)
TT = Join$(Array(x(i, 1), x(i, 2)))
.Item(TT) = (Array(x(i, 3), x(i, 4)))
Next
End With
With Worksheets("TIMESPAN")
'.Range("D5:E" & Rows.Count).ClearContents 'if you want to clear cells before you copy the cells
For Each cell In .Range("A5", .Cells(Rows.Count, "A").End(xlUp))
TT = Join$(Array(cell, cell.Offset(, 1)))
If dic.exists(TT) Then
cell.Offset(, 3).Resize(, 2) = dic.Item(TT)
End If
Next
End With
End Sub
Bookmarks