Copie de données d'un classeur vers un autre classeur

Option Compare Text
Public Ecraser As Boolean

Sub Importer()

Freeze

'Déclarations
    Dim fso As Object
    Dim f As Object, f1 As Object, f2 As Object
    Dim monrepertoire As String
    Set fso = CreateObject("Scripting.FileSystemObject")

'Chemin de fichier
    monrepertoire = ThisWorkbook.Path
    
'Ecraser les données déjà importées ou non ? Imprimer ou non ?
    If MsgBox("Les Fiches vont être cherchées dans le dossier parent de ce fichier ainsi que les sous-dossiers." & Chr(10) & "Elles doivent porter un nom sous la forme : FICHE - *" & Chr(10) & Chr(10) & "Continuer ?", vbYesNo) = vbNo Then Exit Sub
    NbImportées = ThisWorkbook.Sheets("Données").Range("a65536").End(xlUp).Row - 1
    If NbImportées > 0 Then
        For X = 2 To 2 + NbImportées
            msg = msg & ThisWorkbook.Sheets("Données").Cells(X, 1).Value & vbLf
        Next X
        deja.ListBox1.RowSource = "=tabimport"
        deja.Show
        deja.Repaint
        If deja.Tag = "oui" Then Ecraser = True Else Ecraser = False
    End If
    
'Compte les fichiers
    For Each f1 In fso.GetFolder(monrepertoire).SubFolders
        nbfich = nbfich + f1.Files.Count
        For Each f2 In f1.Files
            If f2.Name Like "FICHE -*" Then Else nbfich = nbfich - 1
        Next
    Next f1
    If Ecraser = True Then nbfich = nbfich Else nbfich = nbfich - NbImportées
    If nbfich = 0 Then GoTo Finir

'Nettoie les données précédentes
    If Ecraser <> False Then Call Initialiser
    
    
'BOUCLE SUR LES FICHIERS "Fiches -*" _________________________
    Dim i As Integer
    i = 1
    numfich = 1
    
    For Each f1 In fso.GetFolder(monrepertoire).SubFolders
        For Each f2 In f1.Files
            If f2.Name Like "FICHE -*" Then
                If Ecraser = False Then
                    For X = 2 To 2 + NbImportées
                        If ThisWorkbook.Sheets("Données").Cells(X, 1).Value Like f2.Name Then GoTo PasserFichier
                    Next X
                End If
                    numfich = numfich + 1
                Call RecupInfosFiches(Folder:=f2.Path, Nom:=f2.Name, X:=i) '>>>>>>>>>   APPEL A LA FONCTION RecupInfoFiches
                i = i + 1
            ThisWorkbook.Sheets("Données").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = f2.Name
            End If
PasserFichier:
        Next f2
    Next f1
    

Finir:
    If nbfich = 0 Then MsgBox ("Aucun nouveau fichier n'a été trouvé")
    
End Sub

Function RecupInfosFiches(Folder As Variant, Nom As Variant, X As Integer)

    'Fichier excel "Fiche - *"
    Dim Fi As Workbook
    Dim Fiche As Worksheet
    
    'Fichier excel "Bilan"
    Dim Bilans As Workbook
    Dim Données As Worksheet
    
    Set Bilans = ThisWorkbook
    Set Données = Worksheets("Données")
    
    Dim i As Integer
    Dim j As Integer
    
    i = 2
    j = 1
    
    Workbooks.Open Filename:=Folder
    Set Fi = Workbooks(Nom)
    With Fi
        Set Fiche = Worksheets("Fiche")
    End With

    Bilans.DonnéesFC.Cells(i, j) = Fiche.Cells(11, 4)
    
    i = i + 1
    j = j + 1

End Function