Bonjour,
Je sollicite votre aide pour écrire une macro qui vient ouvrir différents fichiers dans un emplacement spécifique avec la même structure pour copier les données et ainsi générer une BDD.
Mon fichier TEST est copié sur le bureau et est composé de 2 classeurs.
Pour chaque classeur on retrouve les mêmes informations. En B1 le client, en B8 la commande et en D8 la date.
J’aimerai que dans le classeur macro (c’est dans ce classeur qu’il y a ma macro) le client apparaisse en A3, la commande en B3 et la date en C3 pour me créer une BDD sans que j’ai à ouvrir tous les classeur (en réalité j’en ai des centaines, j’en ai mis deux pour l’exemple).
Classeur1.xlsx (7,9 Ko) Classeur2.xlsx (9,1 Ko) macro.xlsm (21,6 Ko)
Voici ma macro qui ne fonctionne pas :
Sub listerLesFichiers()
Application.ScreenUpdating = False
Dim chemin As String, Fichier As String
’ On a besoin du chemin absolu du dossier
’ Doit se terminer par
chemin = « CHEMIN »
’ La fonction Dir(chemin, mode) permet de parcourir un dossier
’ Ici je rajoute à mon chemin « *.xlsx »,
’ pour ne retrouver que mes fichiers Excel
’ vbNormal permet de ne récupérer que des fichiers,
’ vbDirectory récupère tout (dossiers et fichiers)
Fichier = Dir(chemin & « .xlsx », vbNormal)
’ boucle pour ouvrir tous les fichiers un à un
Do While Fichier <> « »
With Workbooks.Open(chemin & Fichier)
.Activate
DerLigneVide = Workbooks("macro.xlsm").Sheets("Feuil1").Range("A3").End(xlDown).Row + 1
Workbooks("macro.xlsm").Sheets("Feuil1").Cells(DerLigneVide, 1) = ActiveWorkbook.Sheets("Feuil1").Range("B1")
DerLigneVide1 = Workbooks("macro.xlsm").Sheets("Feuil1").Range("B3").End(xlDown).Row + 1
Workbooks("macro.xlsm").Sheets("Feuil1").Cells(DerLigneVide1, 1) = ActiveWorkbook.Sheets("Feuil1").Range("B8")
DerLigneVide = Workbooks("macro.xlsm").Sheets("Feuil1").Range("C3").End(xlDown).Row + 1
Workbooks("macro.xlsm").Sheets("Feuil1").Cells(DerLigneVide, 1) = ActiveWorkbook.Sheets("Feuil1").Range("D8")
End With
Fichier = Dir
Loop
Call FermerTousClasseurs
Application.ScreenUpdating = True
End Sub
Sub FermerTousClasseurs()
Application.DisplayAlerts = False
Dim Classeur As Workbook
For Each Classeur In Workbooks
If Classeur.Name <> ThisWorkbook.Name Then
Classeur.Close SaveChanges:=False
End If
Next Classeur
Application.DisplayAlerts = True
End Sub
Merci pour votre aide,
Bonne journée,
