Relazione tra numeri di due file

Sub importa() ' da mettere nel file importazione
Set sh1 = ThisWorkbook.Sheets("Importazione")
LR1 = Cells(Rows.Count, "A").End(xlUp).Row
Set sh2 = Workbooks.Open("F:\Download\Matrice.xlsx").Sheets("Matrice")
LR2 = Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To LR1
  num = sh1.Cells(r, "A")
  For rr = 2 To LR2
    If sh2.Cells(r, "A") = num Then
      sh2.Range("B" & rr & ":D" & rr).Copy sh1.Cells(r, "B")
    End If
  Next
Next
End Sub

Sub ScriviSuFileImportazioni()
Dim ur As Long
Dim rng As Range
Dim rngRicerca As Range
Dim cel As Range
ur = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a2:a" & ur)
For Each cel In rng
With Workbooks("Importazione.xlsx").Sheets("Importazione").Range("A:A")
            Set rngRicerca = .Find(What:=cel.Value, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                rngRicerca.Offset(0, 1).Value = cel.Offset(0, 1).Value
                rngRicerca.Offset(0, 2).Value = cel.Offset(0, 2).Value
                rngRicerca.Offset(0, 3).Value = cel.Offset(0, 3).Value
            End If
        End With
Next cel
End Sub

Option Explicit
Sub copia()
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Dim Percorso As String, nomeFile As String, Fg As String, Rg As Object, Area As Range
Dim Ur1 As Long, Ur2 As Long, X As Long, R As Long, Rr As Long
Percorso = ThisWorkbook.Path
Set Wb1 = Workbooks("Importazione.xlsm") 'Nome files 1, Casomai cambiare
Set Ws1 = Wb1.Worksheets("Importazione") ' Nome foglio 1, Casomai cambiare
Ur1 = Ws1.Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = True
If Ur1 > 1 Then Ws1.Range("B2:D" & Ur1).ClearContents
    Ur1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
    nomeFile = "matrice.xlsx" 'Nome files 2, Casomai cambiare
    Workbooks.Open (Percorso & "\" & nomeFile)
    Set Wb2 = Workbooks(nomeFile)
    Fg = "matrice" 'Nome foglio 2, Casomai cambiare
    Set Ws2 = Wb2.Worksheets(Fg)
Ur1 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
R = 2
Set Area = Ws2.Range("A2:A" & Ur1)
    For X = 2 To Ur1
        Set Rg = Area.Find(Ws1.Cells(X, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If Not Rg Is Nothing Then
            Rr = Rg.Row
            Ws1.Cells(X, 2) = Ws2.Cells(Rr, 2)
            Ws1.Cells(X, 3) = Ws2.Cells(Rr, 3)
            Ws1.Cells(X, 4) = Ws2.Cells(Rr, 4)
            R = R + 1
        End If
    Next X
Wb2.Close (Percorso & "\" & nomeFile)
Application.ScreenUpdating = True
Set Wb1 = Nothing
Set Wb2 = Nothing
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Area = Nothing
Set Rg = Nothing
MsgBox "Fatto"
End Sub