Sub Test_6()
Dim i&, j&, D As Object
Set D = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Sheets("Sheet1")
For i = 7 To .Cells(.Rows.Count, 14).End(3).Row
For j = 14 To 18
If .Cells(i, j) <> "" Then
If Not D.Exists(.Cells(i, j) & .Cells(i, j + 5)) Then
Application.Union(.Cells(i, j), .Cells(i, j + 5)).Copy _
Sheets("Sheet3").Cells(Application.Rows.Count, 1).End(3)(2)
D(.Cells(i, j) & .Cells(i, j + 5)) = ""
End If
End If
Next j
Next i
End With
End Sub