La méthode Copy de l'objet Range a échoué

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
7828
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
11 octobre 2019
- 14 juin 2019 à 12:12
Bonjour,

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

2 réponses

Messages postés
7828
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
11 octobre 2019
1218
0
Merci
Re,

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)

Patrice33740
Messages postés
7828
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
11 octobre 2019
1218 -
Soit pour une procédure simple à configurer :
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

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 Patrice et merci pour votre grande réactivité.

Après avoir appliqué les modifications que vous m'avez dites, j'ai une erreur 1004 : définie par l'application ou par l'objet, pour la ligne
Set rng = rng.Offset(5).Resize(rng.Rows.Count - 5)
Patrice33740
Messages postés
7828
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
11 octobre 2019
1218 -
Copies intégralement le code ci-dessus (en #2), il fonctionne à condition de définir correctement les valeurs de lig, col et nlt
Commenter la réponse de Herkabe