Remplir une base de donnée en fonction de plusieurs formulaires
d
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!
T
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
d
Merci beaucoup! Bonne journée