Compiler des tableaux à la suite [Résolu]

Messages postés
17
Date d'inscription
dimanche 31 mars 2019
Statut
Membre
Dernière intervention
14 juin 2019
- - Dernière réponse : Patrice33740
Messages postés
7833
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
20 octobre 2019
- 12 juin 2019 à 18:50
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.

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
Afficher la suite 

4 réponses

Meilleure réponse
Messages postés
7833
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
20 octobre 2019
1226
1
Merci
Bonjour,

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



Cordialement
Patrice

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 64526 internautes nous ont dit merci ce mois-ci

Commenter la réponse de Patrice33740
Messages postés
7833
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
20 octobre 2019
1226
1
Merci
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 :
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 

Cordialement
Patrice

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 64526 internautes nous ont dit merci ce mois-ci

Commenter la réponse de Patrice33740
Messages postés
17
Date d'inscription
dimanche 31 mars 2019
Statut
Membre
Dernière intervention
14 juin 2019
0
Merci
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.
Commenter la réponse de Herkabe
Messages postés
17
Date d'inscription
dimanche 31 mars 2019
Statut
Membre
Dernière intervention
14 juin 2019
0
Merci
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!
Patrice33740
Messages postés
7833
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
20 octobre 2019
1226 -
De rien.

En regardant l'image de ton tableau il y a 2 lignes de titre (ou 3 avec la première ligne vide)
Pour éviter le copier les lignes 2 et 3 des autre feuilles, tu peux remplacer :
Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
Par
Set rng = rng.Offset(3).Resize(rng.Rows.Count - 3)
Commenter la réponse de Herkabe