Remplir une base de donnée en fonction de plusieurs formulaires

Bonjour,

J'ai créer un fichier excel style template à compléter, j'aimerais que ces infos soient transférées dans un fichier base de données. Je vous mets les fichier en pièce jointe. Je ne sais pas trop comment faire pour que la macro puisse lire tous les fichiers formulaire présent dans un dossier pour compléter la base de donnée.

Merci d'avance pour votre aide!

34basededonnees.xlsx (8.62 Ko)

Bonjour,

Voici un code qui devrait faire ce que tu demandes à condition bien sûr que les classeurs sont construits comme ceux postés en exemple !

Les contraintes :

  • toutes les feuilles des classeurs "Formulaire" se nomment "Feuil1", si ce n'est pas le cas, il te faudra adapter
  • tous les tableaux de ces dernières se trouvent exactement à la même adresse et construits de la même façon
  • tous les classeurs "Formulaire" sont dans le même dossier que le classeur "Basededonnées"
  • le code ci-dessous doit être mis dans un module standard du classeur "Basededonnées" qui sera enregistré en ".xlsm" pour pouvoir contenir des macros. :
Sub Test()

    Dim FeBase As Worksheet
    Dim Tbl() As String
    Dim Chemin As String
    Dim NomFeuille As String
    Dim I As Long
    Dim J As Long

    Set FeBase = ThisWorkbook.Worksheets("Feuil1")

    Chemin = ThisWorkbook.Path & "\"

    NomFeuille = "Feuil1"

    Tbl() = RecupFichiers(Chemin)

    If Not (Not Tbl()) Then

        J = 2

        With FeBase

            For I = 1 To UBound(Tbl)

                .Cells(J, 1).Value = RecupValeur(Chemin, Tbl(I), NomFeuille, "D2") 'numéro formulmaire
                .Cells(J, 2).Value = RecupValeur(Chemin, Tbl(I), NomFeuille, "C3") 'nom
                .Cells(J, 3).Value = RecupValeur(Chemin, Tbl(I), NomFeuille, "E3")  'prénom
                .Cells(J, 4).Value = RecupValeur(Chemin, Tbl(I), NomFeuille, "C4")  'age
                .Cells(J, 5).Value = RecupValeur(Chemin, Tbl(I), NomFeuille, "C5")  'adresse
                .Cells(J, 6).Value = RecupValeur(Chemin, Tbl(I), NomFeuille, "C6")  'métier

                J = J + 1

            Next I

        End With

    End If

End Sub

Function RecupValeur(Chemin As String, _
                     NomClasseur As String, _
                     NomFeuille As String, _
                     Cellule As String)

    Dim Arg As String

    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'si c'est une plage, message et fin
    If InStr(Cellule, ":") Then

        MsgBox "Une seule cellule en argument", , "Cellule unique.": Exit Function

    End If

    'ignore si déjà en référence R1C1
    On Error Resume Next
    Cellule = Range(Cellule).Address(, , xlR1C1)

    'construit l'argument
    Arg = "'" & Chemin & "[" & NomClasseur & "]" & NomFeuille & "'!" & Cellule

    'récup de la valeur
    RecupValeur = Application.ExecuteExcel4Macro(Arg)

End Function

Function RecupFichiers(Chemin As String) As String()

    Dim Tbl() As String
    Dim Fichier As String
    Dim I As Integer

    Fichier = Dir(Chemin & "*.xls*")

    Do While (Len(Fichier) > 0)

        I = I + 1: ReDim Preserve Tbl(1 To I)
        Tbl(I) = Fichier
        Fichier = Dir()

    Loop

   RecupFichiers = Tbl()

End Function

Merci beaucoup! Bonne journée

Rechercher des sujets similaires à "remplir base donnee fonction formulaires"