Compiler des tableaux à la suite
Résolu
Herkabe
Messages postés
18
Statut
Membre
-
Patrice33740 Messages postés 8930 Statut Membre -
Patrice33740 Messages postés 8930 Statut Membre -
Bonjour,
J'ai créé un compilateur en arrangeant un code trouvé sur internet selon mon besoin.
Ce compilateur doit me permettre, indépendamment du format des tableaux à compiler (qui ont tous la même forme selon le type de données), de copier les valeurs de tableaux contenus dans différents classeurs afin de les assembler dans un nouveau classeur.
Oui mais voilà, étant novice en VBA, mon code fonctionne mal, et j'ai du mal à trouver les erreurs dans le code.
Je rencontre deux problèmes :
-Après avoir copié un tableau correctement, la macro copie seulement les en-tête des tableaux suivants et les colle après l'en-tête du premier tableau, sur les données!
-Le deuxième problème vous l'aurez compris, la macro copie les en-tête de tous les tableaux alors que ce n'est pas nécessaire. Comme ils ont tous la même en-tête, la copier une seule fois suffit...
Je m'en remets à vous. Au plaisir de vous lire. Merci.
J'ai créé un compilateur en arrangeant un code trouvé sur internet selon mon besoin.
Ce compilateur doit me permettre, indépendamment du format des tableaux à compiler (qui ont tous la même forme selon le type de données), de copier les valeurs de tableaux contenus dans différents classeurs afin de les assembler dans un nouveau classeur.
Oui mais voilà, étant novice en VBA, mon code fonctionne mal, et j'ai du mal à trouver les erreurs dans le code.
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 i As Integer
' Définir le répertoire à lire
pth = "C:\Users\Herkabe\Desktop\Reporting WC\Flux Achats-Ventes"
' 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)
' Compte le nombre de colonnes à copier
dercol = Cells(6, Columns.Count).End(xlToLeft).Column
' Copie les colonnes une par une
For i = 1 To dercol Step 1
' Copier la colonne
Set rng = wbk.Worksheets(1).UsedRange
rng.Copy dst
Next
' Fermer le fichier sans le modifier
wbk.Close False
' Destination suivante
With res.Worksheets(1)
Set dst = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
End If
Next fic
End Sub
Je rencontre deux problèmes :
-Après avoir copié un tableau correctement, la macro copie seulement les en-tête des tableaux suivants et les colle après l'en-tête du premier tableau, sur les données!
-Le deuxième problème vous l'aurez compris, la macro copie les en-tête de tous les tableaux alors que ce n'est pas nécessaire. Comme ils ont tous la même en-tête, la copier une seule fois suffit...
Je m'en remets à vous. Au plaisir de vous lire. Merci.
Configuration: Windows / Chrome 74.0.3729.169
A voir également:
- Compiler des tableaux à la suite
- Tableaux croisés dynamiques - Guide
- Fusionner deux tableaux excel - Guide
- Tableau des codes ascii - Guide
- Comment compiler des pdf - Guide
- Barbara veut calculer automatiquement son budget dans un tableau. citez un des logiciels lui permettant de faire des calculs sur des tableaux de nombres (tableur). - Forum Musique / Radio / Clip
4 réponses
Bonjour,
Je suppose que tes tableaux commencent en A6 (sinon corriges la constante adr) :
Je suppose que tes tableaux commencent en A6 (sinon corriges la constante adr) :
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 adr$ = "A6" 'Adresse de la première cellule des tableaux à copier
' Définir le répertoire à lire
pth = "C:\Users\Herkabe\Desktop\Reporting WC\Flux Achats-Ventes"
' 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 le tableau à copier
Set rng = wbk.Worksheets(1).Range(adr).CurrentRegion
' Si l'en-tête est déjà copié ....
If etc Then
' ... reduire le tableau aux données sans en-tête
Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
End If
' Copier le tableau
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
Re,
Mais il ne s'agit pas de tableaux !!!! - A mauvaise question : mauvaise réponse ....
(un tableau ne comporte pas de ligne vide, ni de colonne vide)
En outre, il ne fallait pas enlever le $ sur la ligne :
Avec ce genre de feuille, il faut savoir quelle est la colonne qui est obligatoirement remplie pour déterminer où se situe la dernière ligne. je suppose que c'est la F :
Mais il ne s'agit pas de tableaux !!!! - A mauvaise question : mauvaise réponse ....
(un tableau ne comporte pas de ligne vide, ni de colonne vide)
En outre, il ne fallait pas enlever le $ sur la ligne :
Const adr$ = "A6"si tu veux l'enlever il faut écrire :
Const adr As String = "A6"
Avec ce genre de feuille, il faut savoir quelle est la colonne qui est obligatoirement remplie pour déterminer où se situe la dernière ligne. je suppose que c'est la F :
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$ = "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 = 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(1).Resize(rng.Rows.Count - 1)
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
Bonjour, et merci pour ta réponse.
Malheureusement, la macro ne se contente plus que de recopier une seule cellule (A5), en A1 de la nouvelle feuille et... je ne comprends pas pourquoi (j'ai enlevé le $ à côté du adr au début pourtant, et même avec ça faisait la même chose).
J'ai bien mis la macro dans un nouveau module avec Option Explicit.
Ci-joint une capture d'écran pour montrer la mise en forme du tableau un peu particulière, ça aidera sûrement.
EDIT : Et du coup non le tableau commence véritablement en A5, mais pour compter les colonnes j'ai pris en A6 car les en-tête vont plus loin qu'en A5.
Malheureusement, la macro ne se contente plus que de recopier une seule cellule (A5), en A1 de la nouvelle feuille et... je ne comprends pas pourquoi (j'ai enlevé le $ à côté du adr au début pourtant, et même avec ça faisait la même chose).
J'ai bien mis la macro dans un nouveau module avec Option Explicit.
Ci-joint une capture d'écran pour montrer la mise en forme du tableau un peu particulière, ça aidera sûrement.
EDIT : Et du coup non le tableau commence véritablement en A5, mais pour compter les colonnes j'ai pris en A6 car les en-tête vont plus loin qu'en A5.
Désolé pour mon imprécision, j'aurais du me renseigner davantage avant de poser ma question.
Ceci, merci beaucoup pour ton code patrice, sujet résolu!
Ceci, merci beaucoup pour ton code patrice, sujet résolu!
