Sujet Précédent Sujet Suivant

Compiler des tableaux à la suite

Résolu/Fermé
Herkabe Messages postés 17 Date d'inscription dimanche 31 mars 2019 Statut Membre Dernière intervention 14 juin 2019 - 12 juin 2019 à 09:48
Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 - 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

4 réponses

Réponse 1 / 4
Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 779
Modifié le 12 juin 2019 à 10:39
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
1
Réponse 2 / 4
Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 779
Modifié le 12 juin 2019 à 12:34
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

1
Réponse 3 / 4
Herkabe Messages postés 17 Date d'inscription dimanche 31 mars 2019 Statut Membre Dernière intervention 14 juin 2019
Modifié le 12 juin 2019 à 11:16
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.
0
Réponse 4 / 4
Herkabe Messages postés 17 Date d'inscription dimanche 31 mars 2019 Statut Membre Dernière intervention 14 juin 2019
12 juin 2019 à 14:01
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!
0
Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 779
12 juin 2019 à 18:50
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)
0

Discussions similaires

code ascii
Thomas13_9924 -
Dalfab -

2 réponses
Bibliothèque
cosjac85 -
renard bleu -

3 réponses
CALCULS
smart19 -
Dracknard -

4 réponses
Trouver un mot dans un tableau de mot
Lakaiz -
[Dal] -

3 réponses
logiciel pour tableau
aket69 -
aket69 -

3 réponses