Je suis déjà venu ici il y a deux trois jours pour m'aider à coder mon compilateur, chose que j'ai finalement réussie à faire grâce à Patrice.
Cependant, j'aurais aimé utiliser le compilateur pour tout type de forme de données (c-à-d indépendamment de la variation du nombre de lignes ou de colonnes).
Sur les fichiers de départ que je souhaitais compiler, il y avait une centaines de lignes par fichiers, pour 13 colonnes, et 2 lignes de titre. Sur les nouveau fichiers, toujours une centaine de lignes mais il y a désormais 19 colonnes.
La macro, qui fonctionne très bien pour compiler les fichiers à 13 colonnes, ne fonctionnent subitement plus pour les fichiers qui ont plus de 13 colonnes (pas encore testé pour moins).
Voici le code :
Option Explicit Sub TEST2() Dim fso As Object 'Système de fichiers Dim rep As Object 'Répertoire Dim cfr As Object 'Collection de fichiers du répertoire Dim fic As Object 'Fichier (élément de la collection cfr) Dim wbk As Workbook 'Classeur Dim res As Workbook 'Classeur resultat Dim rng As Range 'Plage de cellules Dim dst As Range 'Cellule de destination Dim pth As String 'Chemin du répertoire Dim etc As Boolean 'En tête copié Const lig$ = "5" 'Adresse de la première ligne des tableaux à copier Const col$ = "F" 'Adresse de la colonne à tester
' Définir le répertoire à lire pth = "C:\Users\vdesigau\Desktop\Reporting WC\BA" ' Créer le fichier résultat Set res = Workbooks.Add(xlWBATWorksheet) Set dst = res.Worksheets(1).Range("A1") ' Lecture du répertoire Set fso = CreateObject("Scripting.FileSystemObject") Set rep = fso.GetFolder(pth) Set cfr = rep.Files ' Contrôler chaque fichier du répertoire For Each fic In cfr ' - Vérifier s'il s'agit d'un fichier Excel... If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then ' ... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways) ' Définir les lignes à copier With wbk.Worksheets(1) Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row) End With ' Si l'en-tête est déjà copié .... If etc Then ' ... réduire les lignes aux données sans en-tête Set rng = rng.Offset(3).Resize(rng.Rows.Count - 3) End If ' Copier les lignes entières rng.Copy dst ' En-tête copié etc = True ' Destination suivante Set dst = dst.Offset(rng.Rows.Count) ' Fermer le fichier sans le modifier wbk.Close False End If Next fic
End Sub
Concernant les deux types de fichiers, il faut copier à partir de la ligne 5, mais j'ai testé pour toutes les colonnes la constante col, rien n'y fait!
Voici des images des fichiers pour donner une idée:
Ma question : Que faut-il changer dans le code pour pouvoir l'adapter facilement à tout type de fichiers (l'erreur est localisée à la ligne rng.Copy dst) ?
La macro ne dépend pas du nombre de colonnes car elle copie des lignes entières !
Il faut ajuster les constantes lig et col :
lig c'est la première ligne des titres du tableau donc = 1 dans le second cas.
col c'est la colonne qui sert à déterminer le nombre de lignes à copier, = "F" me semble être la bonne
D'autre part tes nouveaux tableaux ont 5 lignes de titre (au lieu de 3), il faut donc remplacer
Set rng = rng.Offset(3).Resize(rng.Rows.Count - 3)
par
Set rng = rng.Offset(5).Resize(rng.Rows.Count - 5)
Option Explicit
Sub Regrouper_Fichiers()
Dim fso As Object 'Système de fichiers
Dim rep As Object 'Répertoire
Dim cfr As Object 'Collection de fichiers du répertoire
Dim fic As Object 'Fichier (élément de la collection cfr)
Dim wbk As Workbook 'Classeur
Dim res As Workbook 'Classeur resultat
Dim rng As Range 'Plage de cellules
Dim dst As Range 'Cellule de destination
Dim pth As String 'Chemin du répertoire
Dim etc As Boolean 'En tête copié
Const lig$ = "1" 'Adresse de la première ligne des tableaux à copier
Const col$ = "F" 'Adresse de la colonne à tester
Const nlt& = 5 'Nombre de lignes de titre à copier (une seule fois)
' Définir le répertoire à lire
pth = ThisWorkbook.Path & "\tmp"
' Créer le fichier résultat
Set res = Workbooks.Add(xlWBATWorksheet)
Set dst = res.Worksheets(1).Range("A1")
' Lecture du répertoire
Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.GetFolder(pth)
Set cfr = rep.Files
' Contrôler chaque fichier du répertoire
For Each fic In cfr
' - Vérifier s'il s'agit d'un fichier Excel...
If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then
' ... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways)
' Définir les lignes à copier
With wbk.Worksheets(1)
Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row)
End With
' Si l'en-tête est déjà copié ....
If etc Then
' ... réduire les lignes aux données sans en-tête
Set rng = rng.Offset(nlt).Resize(rng.Rows.Count - nlt)
End If
' Copier les lignes entières
rng.Copy dst
' En-tête copié
etc = True
' Destination suivante
Set dst = dst.Offset(rng.Rows.Count)
' Fermer le fichier sans le modifier
wbk.Close False
End If
Next fic
End Sub
Option Explicit Sub Regrouper_Fichiers() Dim fso As Object 'Système de fichiers Dim rep As Object 'Répertoire Dim cfr As Object 'Collection de fichiers du répertoire Dim fic As Object 'Fichier (élément de la collection cfr) Dim wbk As Workbook 'Classeur Dim res As Workbook 'Classeur resultat Dim rng As Range 'Plage de cellules Dim dst As Range 'Cellule de destination Dim pth As String 'Chemin du répertoire Dim etc As Boolean 'En tête copié Const lig$ = "1" 'Adresse de la première ligne des tableaux à copier Const col$ = "F" 'Adresse de la colonne à tester Const nlt& = 5 'Nombre de lignes de titre à copier (une seule fois) ' Définir le répertoire à lire pth = ThisWorkbook.Path & "\tmp" ' Créer le fichier résultat Set res = Workbooks.Add(xlWBATWorksheet) Set dst = res.Worksheets(1).Range("A1") ' Lecture du répertoire Set fso = CreateObject("Scripting.FileSystemObject") Set rep = fso.GetFolder(pth) Set cfr = rep.Files ' Contrôler chaque fichier du répertoire For Each fic In cfr ' - Vérifier s'il s'agit d'un fichier Excel... If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then ' ... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways) ' Définir les lignes à copier With wbk.Worksheets(1) Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row) End With ' Si l'en-tête est déjà copié .... If etc Then ' ... réduire les lignes aux données sans en-tête Set rng = rng.Offset(nlt).Resize(rng.Rows.Count - nlt) End If ' Copier les lignes entières rng.Copy dst ' En-tête copié etc = True ' Destination suivante Set dst = dst.Offset(rng.Rows.Count) ' Fermer le fichier sans le modifier wbk.Close False End If Next fic End Sub