Copiare celle a se trovo corrispondenza

Sub Auto_Open()
Dim Ur1, Ur2, X, rg, Spath As String
Dim wk1 As Workbook: Set wk1 = ThisWorkbook
Dim sh1 As Worksheet: Set sh1 = wk1.Worksheets("Foglio1") ' da cambiare casomai
Spath = ThisWorkbook.Path
Ur1 = sh1.Range("F" & Rows.Count).End(xlUp).Row
    For Each Book In Workbooks
        If Book.Name = "Contraddittorio.xlsx" Then
            Workbooks("Contraddittorio.xlsx").Activate
        End If
    Next Book
    If ActiveWorkbook.Name <> "Contraddittorio.xlsx" Then Workbooks.Open Filename:=Spath & "\Contraddittorio.xlsx"
        Dim wk2 As Workbook: Set wk2 = ActiveWorkbook
        Dim sh2 As Worksheet: Set sh2 = wk2.Worksheets("Foglio1") ' da cambiare casomai
        Ur2 = sh2.Range("F" & Rows.Count).End(xlUp).Row
        wk1.Activate
        For X = 2 To Ur1
            If Application.WorksheetFunction.CountIf(sh2.Range("F1:F" & Ur2), sh1.Cells(X, 6)) > 0 Then
                rg = Application.WorksheetFunction.Match(sh1.Cells(X, 6), sh2.Range("F1:F" & Ur2), 0)
                sh2.Range(sh2.Cells(rg, 1), sh2.Cells(rg, 12)).Copy
                sh1.Cells(X, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                sh1.Cells(X, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                'molto lenta causa FC in C ed errore formula in celle F = RIF# sul mio PC
                'sh1.Cells(X, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=False
            End If
        Next
Set sh1 = Nothing
Set sh2 = Nothing
Set wk1 = Nothing
Set wk2 = Nothing
End Sub