[XL 2013-2016] Compiler des tableaux à la suite

Question

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 &amp; "\" &amp; 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...

paritec · Answer

Quel est donc l'utilité de copier les colonnes une par une??? si tu peux, tu joins un dossier zippé avec deux fichiers à regrouper et le fichier qui comporte la macro Regrouper_fichier et on va te faire cela a+ Papou...

paritec · Answer

Re bonjour Hardebeke le forum

bon alors difficile de te suivre mais je coure !!!

exemple dans ton fichier ACH LP tu veux copier la plage D9 : M 271 c'est bien cela et ensuite ligne suivante, on colle la plage suivant trouvé dans le fichier VENT LP c'est bien cela???

a te relire

a+

Papou

paritec · Answer

Re Harkebeke le forum

bon là plus le temps on verra cela cet après midi,

et pour le maximum?? de quoi de colonnes??? mais pas besoin de toute ta gymnastique pour le faire

et pour les entêtes, moi je n'ai pas vu grand choses ou alors tu veux la ligne 8 ???

a+

Papou

paritec · Answer

Re Harkebeke le forum

bon je vois que tu essayes de t'en sortir alors la solution je te la donne, tu ne copies pas de cells(1,1) à la fin mais de cells(9,1) à la fin et en premier, avant ta boucles for each, ou du moins en premier dans ta boucle tu copies colles les lignes 4 et 5 en premier dans ta feuille de récupération, et les autres plages en dessous.

si tu n'y arrives pas redis le je ferai mais c'est mieux si tu tentes tout seul (pour toi)

a+

Papou

Patrice33740 · Answer

Re,

Même remarque que sur CCM et Developpez : le cross posting sans informer les helpers, c'est un manque de respect : t'es pas le seul à poser des questions, au lieu de nous faire perdre du temps on pourrait répondre aux autres !

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