Replicare dei valori

Sub trova()
Dim ur, ur1, x, r, Rg As Object
ur = Sheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row
ur1 = Sheets("Foglio2").Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To ur1
Set Rg = Sheets("Foglio1").Range("A1:A" & ur).Find(Sheets("Foglio2").Cells(x, 1), LookIn:=xlValues, LookAt:=xlWhole)
    If Rg Is Nothing Then
        MsgBox "nessuna corrispondenza"
    Else
        r = Rg.Row
        If Sheets("Foglio1").Cells(r, 2) = "" Then
            Sheets("Foglio1").Cells(r, 2) = Sheets("Foglio2").Cells(x, 2)
        Else
            Sheets("Foglio1").Cells(r, 2) = Sheets("Foglio1").Cells(r, 2) & ", " & Sheets("Foglio2").Cells(x, 2)
        End If
    End If
Next
MsgBox "Fatto"
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub
Dim ur, r, c As Object, Msg As String, val As Long, Tot As Long
ur = Sheets("Foglio2").Range("A" & Rows.Count).End(xlUp).Row
    If Not Intersect(Target, Range("A2:A1000")) Is Nothing Then
        val = Target.Offset(0, 0)
         With Sheets("Foglio2").Range("A1:A" & ur)
            Set c = .Find(val, LookIn:=xlValues, LookAt:=xlWhole)
                If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                r = c.Row
                Msg = Msg & Sheets("Foglio2").Cells(r, 2) & ","
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        End With
   End If
Application.EnableEvents = False
    Target.Offset(0, 1) = Msg
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ur, r, c As Object, Msg As String, val As Long, Tot As Long
Application.EnableEvents = False
ur = Sheets("Foglio2").Range("A" & Rows.Count).End(xlUp).Row
    If Not Intersect(Target, Range("A2:A1000")) Is Nothing Then
        For Each cell In Target
            If Not cell.Value = "" Then
                val = cell
                 With Sheets("Foglio2").Range("A1:A" & ur)
                    Set c = .Find(val, LookIn:=xlValues, LookAt:=xlWhole)
                        If Not c Is Nothing Then
                        firstAddress = c.Address
                        Do
                        r = c.Row
                        Msg = Msg & Sheets("Foglio2").Cells(r, 2) & ","
                        Set c = .FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
                End With
                cell.Offset(0, 1) = Msg
                Msg = ""
            End If
        Next
   End If
Application.EnableEvents = True
End Sub