Replicare dei valori

Option Explicit
Sub Nomi()
Dim Msg As String, val As String, c As Object, Msg1 As String
Dim ur1, ur2, x, r, firstAddress
Application.ScreenUpdating = False
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1") ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = Worksheets("Foglio2") ' da cambiare casomai
ur1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
ur2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
sh1.Range("k2:k" & ur1).Clear
    For x = 2 To ur1
        Msg = ""
        val = sh1.Cells(x, 4)
        With sh2.Range("A2:A" & ur2)
        Set c = .Find(val, LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                r = c.Row
                If InStr(Msg, sh2.Cells(r, 4)) = 0 Then
                    Msg = Msg & sh2.Cells(r, 4) & ","
                End If
                 If InStr(Msg1, sh2.Cells(r, 7)) = 0 Then
                    Msg1 = Msg1 & sh2.Cells(r, 7) & ","
                End If
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
        If Right(Msg, 1) = "," Then Msg = Left(Msg, Len(Msg) - 1) Else Msg = Msg
        sh1.Cells(x, 11) = Msg
        If Right(Msg1, 1) = "," Then Msg1 = Left(Msg1, Len(Msg1) - 1) Else Msg1 = Msg1
        sh1.Cells(x, 12) = Msg1
    Next
MsgBox "Fatto"
Application.ScreenUpdating = True
Set sh1 = Nothing
Set sh2 = Nothing
Set c = Nothing
End Sub