Formulaires vers BDD macro excel

Option Explicit

Dim Enregistrements()

Sub Import()
'sources : https://silkyroad.developpez.com/vba/boucles/
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    'Dans l'éditeur de macros (Alt+F11):
    'Menu Outils
    'Références
    'Cochez la ligne "Microsoft Scripting RunTime".
    'Cliquez sur le bouton OK pour valider.
    
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim Repertoire As String, BaseDeDonnees As String, NomFeuil As String
    Dim Donnees(13)
    Dim DrLig As Long
    Dim Col As Byte
    
    'Empêche le refraichissement de l'écran pour ne pas ralentir la procédure
    Application.ScreenUpdating = False
    'Constantes : Nom du classeur "bdd", son répertoire et nom de la feuille
    Repertoire = ActiveWorkbook.Path
    BaseDeDonnees = ActiveWorkbook.Name
    NomFeuil = ActiveSheet.Name
    'Va entrer dans la variable tableau "enregistrements"
    'toutes les données contenues en Col B et Col C, en les concaténant
    'de manière à obtenir un tableau des enregistrements sous la forme
    'NomPrénom
    Call CollectInfos
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        If Left(FileItem.Name, 3) = "CRF" Then
            'ouverture du classeur "formulaire"
            Workbooks.Open Repertoire & "/" & FileItem.Name
            With Sheets("Nouveau contrat") 'c'est pour cette ligne que le nom de
            'la feuille est important!!!
                'remplissage des variables avec les données à extraire
                Donnees(0) = .Range("D4")
                Donnees(1) = .Range("D6")
                Donnees(2) = .Range("D7")
                Donnees(3) = .Range("G11")
                Donnees(4) = .Range("G12")
                Donnees(5) = .Range("G13")
                Donnees(6) = .Range("G14")
                Donnees(7) = .Range("G15")
                Donnees(8) = .Range("D13")
                Donnees(9) = .Range("D14")
                Donnees(10) = .Range("D15")
                Donnees(11) = .Range("D16")
                Donnees(12) = .Range("G7")
                Donnees(13) = .Range("G9")
            End With
            'fermeture du classeur "formulaire"
            ActiveWorkbook.Close
            'Si le couple NomPrénom du formulaire n'est pas présent dans la bdd
            If EstPresent(UCase(Donnees(1) & Donnees(2))) = False Then
                'restitution des données dans la base
                With Workbooks(BaseDeDonnees).Sheets(NomFeuil)
                    DrLig = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    For Col = 0 To 13
                        .Cells(DrLig, Col + 1) = Donnees(Col)
                    Next
                End With
            End If
        End If
    Next FileItem
    'réactive le refraichissement de l'écran
    'pas sur que cela soit utile, mais dans le doute...
    Application.ScreenUpdating = True
End Sub

Sub CollectInfos()
Dim Lig As Long, DrLig As Long

With Sheets("BDD")
    DrLig = .Range("B" & Rows.Count).End(xlUp).Row
    For Lig = 0 To DrLig - 1
        ReDim Preserve Enregistrements(Lig)
        Enregistrements(Lig) = UCase(.Cells(Lig + 1, 2) & .Cells(Lig + 1, 3))
    Next
End With
End Sub

Function EstPresent(Enreg As String) As Boolean
Dim i As Long

For i = 0 To UBound(Enregistrements)
    If Enreg = Enregistrements(i) Then
    EstPresent = True
    Exit Function
    End If
Next
EstPresent = False
End Function