Importation de données à partir de plusieurs fichiers Excel
Bonjour à tous,
Je suis novice en VBA et je tente d'écrire depuis quelques jours, un code qui me permettra d'importer le contenu de plusieurs fichiers dans un tout nouveau fichier.
Le contexte
J'ai environ 300 fichiers sous lesquels je dois extraire des données,
La totalité des fichiers sources est logée sous un même répertoire dans l'entreprise et les fichiers commencent tous par le chiffre "1"
Chaque fichier possède plusieurs feuilles,
Les données qui sont à extraire (28 cellules) sont toutes sous la même feuille (onglet) intitulée "Résultat". Cependant, certaines manipulations doivent être effectuées afin d'aligner les informations à extraire sur la même ligne, pour éventuellement en faciliter l'exportation vers le tout nouveau fichier intitulé "Tableau Consolidé.xlsm".
Le nouveau fichier aura une seule feuille (onglet) qui importera les 300 lignes d'informations sous un tableau.
Le code recherché doit :
Ouvrir chaque fichier sur la feuille "Résultat"
Effectuer six (6) manipulations d'informations (voir la macro ci-jointe)
Sub CréationNouvDatas()
'
' CréationNouvDatas Macro
' Copier les informations du COST - Temps par livre
Range("H33:H35").Select
Selection.Copy
ActiveWindow.SmallScroll ToRight:=3
ActiveWindow.SmallScroll Down:=10
ActiveWindow.SmallScroll ToRight:=4
Range("S50").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveWindow.SmallScroll ToRight:=-7
' Copier les informations du COST - Au pied carré
Range("H36:H37").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll ToRight:=8
Range("V50").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
' Copier les informations du VENDANT - Temps par livre
Range("I33:I35").Select
Application.CutCopyMode = False
Selection.Copy
Range("X50").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveWindow.SmallScroll ToRight:=5
ActiveWindow.LargeScroll ToRight:=-1
' Copier les informations du VENDANT - Au pied carré
Range("I36:I37").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.LargeScroll ToRight:=1
Range("AA50").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveWindow.SmallScroll ToRight:=-15
' Enlever le remplissage de couleur noire
Rows("49:50").Select
Range("J49").Activate
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("a50").Select
' Copier toute la ligne d'informations à transférer dans le nouveau tableau
Range("A50:AP50").Select
Application.CutCopyMode = False
Selection.Copy
End Sub
Ouvrir le nouveau fichier "Tableau Consolidé" qui reçoit les informations à la feuille (onglet) "Données"
Insérer une nouvelle ligne dans le tableau existant
Copier les informations préalablement exportées du fichier source (voir la macro ci-jointe)
Sub TransfertInfos
' Importation des données dans nouveau fichier
Windows("Tableau Consolidé.xlsm").Activate
Sheets("Données").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
Fermer le premier fichier source sans sauvegarder
Ouvrir le second fichier source
Répéter les étapes précédentes jusqu'au dernier fichier inclus dans le répertoire.
Les multiples essais
J'ai effectué plusieurs recherches et utilisé des parcelles de code utilisant les notions de LOOP avec DO WHILE. Malheureusement, je n'arrive pas à construire le code adéquatement. Je reconnais mon manque de compréhension des principes du codage VBA et j'avoue humblement que les derniers jours ont soulevé quelques frustrations.
En conclusion, je passe le flambeau à un de vous, mais je souhaite ardemment comprendre et développer l'art du codage VBA, car j'ai d'autres défis qui se présenteront au cours des prochains mois.
Merci de votre généreuse collaboration.
Bonjour,
Pas facile sans aucun fichier pour tester donc, je te laisse les tests. Il te faut mettre tout le code ci-dessous dans un module standard du classeur "Tableau Consolidé.xlsm" et exécuter la sub "Consolider" en ayant au préalable adapter le chemin du dossier où se trouvent les classeurs (variable "Dossier") et le nom de la feuille du classeur "Tableau Consolidé.xlsm" à la ligne de code :
Cl.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)
Sub Consolider()
'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !
Dim TC As Workbook
Dim Cl As Workbook
Dim TValeurs() As Variant
Dim Tbl() As String
Dim Dossier As String
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dossier = "C:\Mon dossier\" 'adapter le chemin
Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"
'récupère les chemins et noms des différents classeurs
Tbl = EnumFichiers(Dossier)
'si trouvés...
If Not (Not Tbl) Then
'ouvre les classeurs
For I = 1 To UBound(Tbl)
Set Cl = Workbooks.Open(Tbl(I))
K = K + 1
'récupère les différentes valeurs...
TValeurs = ManipRecup(Cl)
'...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
For J = 1 To UBound(TValeurs, 2)
Cl.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)
Next I
'ferme sans enregistrer
Cl.Close False
Next I
Else
MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"
End If
End Sub
Function ManipRecup(Cl As Workbook) As Variant()
With Cl.Worksheets("Résultat")
'Copier les informations du COST - Temps par livre
.Range("S50:U50").Value = Application.Transpose(.Range("H33:H35").Value)
'Copier les informations du COST - Au pied carré
.Range("V50:W50").Value = Application.Transpose(.Range("H36:H37").Value)
'Copier les informations du VENDANT - Temps par livre
.Range("X50:Z50").Value = Application.Transpose(.Range("I33:I35").Value)
'Copier les informations du VENDANT - Au pied carré
.Range("AA50:AB50").Value = Application.Transpose(.Range("I36:I37").Value)
'Copier toute la ligne d'informations à transférer dans le nouveau tableau
ManipRecup = .Range("A50:AP50").Value
End With
End Function
Function EnumFichiers(Chemin As String) As String()
Dim TableauFichiers() As String
Dim Fichier As String
Dim I As Integer
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
'récupère les fichiers Excel et ceux commençant par 1
Fichier = Dir(Chemin & "1*.xls*")
Do While (Len(Fichier) > 0)
I = I + 1: ReDim Preserve TableauFichiers(1 To I)
TableauFichiers(I) = Chemin & Fichier
Fichier = Dir()
Loop
EnumFichiers = TableauFichiers()
End Function
Bonjour Theze,
Premièrement, merci pour ta collaboration dans ma quête. J'apprécie grandement les notes explicatives. C'est instructif!
Je comprends qu'il est effectivement difficile de tester sans fichier complémentaire. Cependant, j'ai testé le tout à mon arrivée au bureau et j'ai rencontré une petite erreur de compilation au premier "Next I".
Voici le code adapté avec le chemin. Afin de tester le VBA, j'ai créé une feuille "Onglet" intitulée "Feuil1" dans le fichier de réception.
Sub Consolider()
'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !
Dim TC As Workbook
Dim Cl As Workbook
Dim TValeurs() As Variant
Dim Tbl() As String
Dim Dossier As String
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dossier = "O:\PROPOSITION 2019\" 'adapter le chemin
Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"
'récupère les chemins et noms des différents classeurs
Tbl = EnumFichiers(Dossier)
'si trouvés...
If Not (Not Tbl) Then
'ouvre les classeurs
For I = 1 To UBound(Tbl)
Set Cl = Workbooks.Open(Tbl(I))
K = K + 1
'récupère les différentes valeurs...
TValeurs = ManipRecup(Cl)
'...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
For J = 1 To UBound(TValeurs, 2)
Cl.Worksheets("feuil1").Cells(K, J).Value = TValeurs(1, J)
Next I
'ferme sans enregistrer
Cl.Close False
Next I
Else
MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"
End If
End Sub
Function ManipRecup(Cl As Workbook) As Variant()
With Cl.Worksheets("Résultat")
'Copier les informations du COST - Temps par livre
.Range("S50:U50").Value = Application.Transpose(.Range("H33:H35").Value)
'Copier les informations du COST - Au pied carré
.Range("V50:W50").Value = Application.Transpose(.Range("H36:H37").Value)
'Copier les informations du VENDANT - Temps par livre
.Range("X50:Z50").Value = Application.Transpose(.Range("I33:I35").Value)
'Copier les informations du VENDANT - Au pied carré
.Range("AA50:AB50").Value = Application.Transpose(.Range("I36:I37").Value)
'Copier toute la ligne d'informations à transférer dans le nouveau tableau
ManipRecup = .Range("A50:AP50").Value
End With
End Function
Function EnumFichiers(Chemin As String) As String()
Dim TableauFichiers() As String
Dim Fichier As String
Dim I As Integer
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
'récupère les fichiers Excel et ceux commençant par 1
Fichier = Dir(Chemin & "1*.xls*")
Do While (Len(Fichier) > 0)
I = I + 1: ReDim Preserve TableauFichiers(1 To I)
TableauFichiers(I) = Chemin & Fichier
Fichier = Dir()
Loop
EnumFichiers = TableauFichiers()
End Function
Lors de mes multiples tentatives, j'ai effectivement rencontré des situations similaires.
Merci de ta contribution.
Oups,
Désolé, comme je n'est pas testé
Il faut modifier la variable de contrôle dans la boucle interne :
For J = 1 To UBound(TValeurs, 2)
Cl.Worksheets("feuil1").Cells(K, J).Value = TValeurs(1, J)
Next J '<--- ici, il faut mettre J et non I car déjà utilisée !
Aucun problème!
Modification faite et petit "bog" à la ligne,
'...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
For J = 1 To UBound(TValeurs, 2)
Cl.Worksheets("feuil1").Cells(K, J).Value = TValeurs(1, J) ' <-------- Ligne nécessitant un débogage...
Next J
'ferme sans enregistrer
Cl.Close False
Next I
Le message d'erreur indique :
Erreur d'exécution '9' :
L'indice n'appartient pas à la sélection.
et en appuyant sur le bouton "débogage" l'outil débogage nous dirige à la ligne en question.
Mes observations :
- L'ouverture du 1er fichier à traiter s'effectue correctement.
- Les données portant sur les informations du COST (Temps par livre + Au pied carré) se transpose dans les bonnes cellules de la ligne 50 de la feuille de manipulation.
Il semble que la procédure VBA s'arrête là. Il n'y a aucune donnée pour le volet du VENDANT et le fichier source demeure ouvert.
En espérant ces indices utiles et constructifs.
Au risque de me répéter, un gros merci de ta généreuse collaboration.
Bonjour,
Bon, cette fois-ci j'ai construis trois classeurs pour les tests et apporté les corrections pour que ça fonctionne. Je poste juste la procédure "Consolider()", les deux fonctions n'ayant pas été modifiées :
Sub Consolider()
'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !
Dim TC As Workbook
Dim Cl As Workbook
Dim TValeurs() As Variant
Dim Tbl() As String
Dim Dossier As String
Dim I As Integer
Dim J As Integer
Dim K As Integer
Application.ScreenUpdating = False
Dossier = "O:\PROPOSITION 2019\" 'adapter le chemin
Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"
'récupère les chemins et noms des différents classeurs
Tbl = EnumFichiers(Dossier)
'si trouvés...
If Not (Not Tbl) Then
'ouvre les classeurs
For I = 1 To UBound(Tbl)
Set Cl = Workbooks.Open(Tbl(I))
K = K + 1
'récupère les différentes valeurs...
TValeurs = ManipRecup(Cl)
'...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
For J = 1 To UBound(TValeurs, 2)
TC.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)
Next J
'ferme sans enregistrer
Cl.Close False
Next I
Else
MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"
End If
Application.ScreenUpdating = True
End Sub
Bonjour Theze,
C'est nickel!!! Tout fonctionne. Félicitations.
Cependant, il y a un aspect qui m'avait échappé dans ma requête initiale. Certains fichiers .xls* ont des liaisons avec d'autres classeurs. Cette situation provoque une intervention manuelle afin de répondre de "NE PAS METTRE À JOUR LES LIAISONS".
Serait-il possible de résoudre cette situation par un bout de code, pour les fichiers. xls* concernés?
Merci!
Bonjour,
Essais avec "DisplayAlerts = False" :
Sub Consolider()
'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !
Dim TC As Workbook
Dim Cl As Workbook
Dim TValeurs() As Variant
Dim Tbl() As String
Dim Dossier As String
Dim I As Integer
Dim J As Integer
Dim K As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dossier = "O:\PROPOSITION 2019\" 'adapter le chemin
Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"
'récupère les chemins et noms des différents classeurs
Tbl = EnumFichiers(Dossier)
'si trouvés...
If Not (Not Tbl) Then
'ouvre les classeurs
For I = 1 To UBound(Tbl)
Set Cl = Workbooks.Open(Tbl(I))
K = K + 1
'récupère les différentes valeurs...
TValeurs = ManipRecup(Cl)
'...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
For J = 1 To UBound(TValeurs, 2)
TC.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)
Next J
'ferme sans enregistrer
Cl.Close False
Next I
Else
MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Bonjour,
J'ai ajouter la portion "DisplayAlert = False" et ça n'a malheureusement pas fonctionné.
Si vous pensez à une autre approche, je suis toujours preneur.
Merci à vous.