Transfer entre Classeur Excel

Option Explicit
Sub importt()
Dim fsrc As Worksheet, fdest As Worksheet, csrc As Range, cdest As Range, fcor As Worksheet, ccor As Range
Dim tin() As String, tout() As String, ncor As Integer, lsrc As Long, ldest As Long, i As Integer, scru As Boolean

Set fsrc = Workbooks("AImporter.xlsx").Sheets("NUMISCollector")
Set fdest = ThisWorkbook.Sheets("BaseVide")
Set fcor = ThisWorkbook.Sheets("corespondance")
Set ccor = fcor.[B3]
Set csrc = fsrc.[A2]
Set cdest = fdest.[A2].End(xlDown)
scru = Application.ScreenUpdating
Application.ScreenUpdating = False
Do While ccor <> ""
    ncor = ncor + 1
    ReDim Preserve tin(ncor)
    ReDim Preserve tout(ncor)
    tin(ncor) = ccor
    tout(ncor) = ccor.Offset(, 3)
    Set ccor = ccor.Offset(1)
Loop
ldest = cdest.Row
lsrc = csrc.Row
Do While fsrc.Cells(ldest, 1) <> ""
    For i = 1 To ncor
        fdest.Cells(ldest, tout(i)) = fsrc.Cells(lsrc, tin(i))
    Next i
    lsrc = lsrc + 1
    ldest = ldest + 1
    DoEvents
Loop
Application.ScreenUpdating = scru
End Sub