Discussion :

[Philippe Tulliez]

Préambule
Cette discussion titrée Concaténer 1er onglet de plusieurs classeurs différents m'a donné l'envie d'écrire une nouvelle fonction nommée CopyRange.
Cette fonction est proche de la contribution Regrouper plusieurs feuilles sur une autre. (2003-2010) mais plus légère et plus ouverte quant à la source (possibilité de choisir la cellule de départ) et permettant également d'ajouter une colonne contenant un nom tel que celui du classeur ou de la feuille source.
Cette fonction permet d'importer une liste de données contenue dans une feuille et définie soit par un objet Range, un objet Worksheet ou un ListObject vers une feuille cible dont la plage de cellules commence en A1.

Son usage est surtout utile pour regrouper plusieurs liste de données en une seule.

Contraintes
Mis à part l'objet source, la fonction n'effectue aucune vérification sur les données sources, ni sur le nombre de colonnes, ni si l'orthographe des étiquettes de colonnes sont identiques aux données déjà présentes dans la feuille cible. Il y a donc lieu de faire cette vérification en amont.
Avant d'invoquer la fonction, il est donc important de

• supprimer s'il y a lieu, le filtre des données sources
• de veiller à ce que toutes les données sources soient de même nature (Plage classique ou tableau structuré)
• si la source est un objet type ListObject, outre le filtre, il y a lieu de désactiver la ligne des totaux

Les arguments
Obligatoires

objSource : Objet (Range, Worksheet ou ListObject)
TargetSheet : Objet Worksheet

Optionnels

AddLabel : String. Cet argument permet d'ajouter une colonne dont toutes les lignes copiées contiendront cette valeur (par exemple le nom de la feuille ou du classeur source)
ClearSheet : Boolean si TRUE, Supprime les cellules de TargetSheet
ValueOnly : Boolean si TRUE ne conserve que les valeurs

Code de la procédure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Function CopyRange(objSource As Object, _
                   TargetSheet As Worksheet, _
                   Optional ClearSheet As Boolean, _
                   Optional AddLabel As String, _
                   Optional ValueOnly As Boolean) As Range
  ' Copie données contenues dans objSource vers TargetSheet
  ' Auhor : Philippe Tulliez www.magicoffice.be
  ' Date  : 08/08/2019
  ' Version 1.1
  ' Arguments
  '   ObjSource    - Source des données. Objet WorkSheet, ListObject ou Range
  '   TargetSheet  - objet WorkSheet (Feuille cible)
  '   [AddLabel]   - String
  '   [ClearSheet] - Boolean si TRUE, Supprime les cellules de TargetSheet
  '   [ValueOnly]  - Boolean si TRUE ne conserve que les valeurs
  ' *** Déclaration ***
  Dim rngTarget As Range, rngSource As Range
  Dim flagExit As Boolean
  ' *** Attribution ***
  With objSource
    Select Case TypeName(objSource)
      Case "Worksheet": Set rngSource = .Range("A1").CurrentRegion
      Case "Range": If .Count = 1 Then Set rngSource = .CurrentRegion Else Set rngSource = objSource
      Case "ListObject": Set rngSource = .Range
      Case Else: flagExit = True
    End Select
  End With
  '
  If Not flagExit Then
     Set rngTarget = TargetSheet.Range("A1").CurrentRegion
     With rngTarget
       If Not ClearSheet Then ClearSheet = .Rows.Count = 1
       If ClearSheet Then
          .Cells.Clear: Set rngTarget = .Cells(1, 1)
        Else
          Set rngTarget = .Cells(.Rows.Count + 1, 1)
       End If
     End With
     ' Exportation des données
     With rngSource
     .Offset(Abs(Not ClearSheet)).Resize(.Rows.Count + Not ClearSheet).Copy rngTarget
     End With
     ' *** AddLabel
     If Len(AddLabel) Then
        With rngTarget
          If .Row = 1 Then .Offset(ColumnOffset:=rngSource.Columns.Count).Value = "_SourceName_"
        End With
        With rngSource
         rngTarget.Offset(0 + Abs(rngTarget.Row = 1), .Columns.Count).Resize(.Rows.Count - 1).Value = AddLabel
        End With
     End If
     ' *** ValueOnly
     With rngTarget
       Set CopyRange = .Range("A1").CurrentRegion
       If ValueOnly Then .Value = .Value
     End With
  End If
  ' End Of Process
  Set rngTarget = Nothing: Set rngSource = Nothing
End Function

Classeur de démonstration
Le classeur au format xlsm a été testé avec la version 2010 et 2013.
Malgré le soin apporté à la programmation de cette procédure et aux multiples tests réalisés, il est possible qu'il subsiste un "bug" qui m'aurait échappé. N'hésitez pas à m'en faire part.

Vos remarques et réactions sont les bienvenues.

[toto2022]

Bonjour,
Je vous remercie pour ce code, il fonctionne presque à merveilles pour mon propre besoin !
Lorsque j'ai un onglet vide (sauf la ligne de titre), il m'affiche une erreur dans la Fonction CopyRange à cet endroit :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
     With rngSource
     .Offset(Abs(Not ClearSheet)).Resize(.Rows.Count + Not ClearSheet).Copy rngTarget
     End With

Avez-vous une astuce pour palier à cela ?
Merci d'avance.

[Philippe Tulliez]

Bonjour,

Lorsque j'ai un onglet vide (sauf la ligne de titre), il m'affiche une erreur dans la Fonction CopyRange à cet endroit :

Merci pour votre message, je vais y jeter un coup d’œil.
Pouvez-vous publier le code où vous invoquez la fonction CopyRange

[EDIT]
Pouvez-vous m'indiquer également le numéro d'erreur et son message ?

[toto2022]

Bonjour,

Pouvez-vous publier le code où vous invoquez la fonction CopyRange

Je n'ai pas fait grand chose de plus que le fichier exemple à part supprimer ce qui ne m’intéressait pas

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
 
Sub TestCopyRange_1()
  ' *** Feuilles du même classeur
  ' Déclaration des variables
  Dim rngSource As Range
  Dim tbl()
  Dim Elem As Integer
  Dim addr As String
  ' Affectation
  tbl = Array("Sheets1", "Sheets2","Sheets3")
  If Start(tbl) Then
     ' Parcoure la table
     For Elem = 0 To UBound(tbl)
       Select Case tbl(Elem)
         'Case "Mars 13": addr = "C5"
         'Case "Avril 13": addr = "A1:F6"
         Case Else: addr = "A1"
       End Select
       ' Affectation de la source
       Set rngSource = ThisWorkbook.Worksheets(tbl(Elem)).Range(addr)
       ' Importation
       CopyRange rngSource, _
                   shtTarget, _
                   ClearSheet:=Elem = 0, _
                   AddLabel:=rngSource.Worksheet.Name
     Next
     shtTarget.Cells.EntireColumn.AutoFit
  End If
  ' End of process
  Set rngSource = Nothing
End Sub

[EDIT]
Pouvez-vous m'indiquer également le numéro d'erreur et son message ?

Erreur d’exécution '1004'
Erreur définie par l'application ou par l'objet

[Philippe Tulliez]

Bonjour,
Difficile de vérifier si la fonction CopyRange a une défaillance, si vous modifiez le code des procédures des tests sans également connaître l'état du classeur.
Vous avez modifié la 10 tbl = Array("Sheets1", "Sheets2","Sheets3") et mis en commentaire les lignes 15 et 16
Cela signifie que le classeur doit avoir des feuilles nommées "Sheets1", "Sheets2","Sheets3" et que les tables doivent commencer en cellule A1 dans chacune de ces feuilles

J'ai refait les tests avec les mêmes conditions et je n'ai pas de souci

[toto2022]

Bonjour,
Difficile de vérifier si la fonction CopyRange a une défaillance, si vous modifiez le code des procédures des tests sans également connaître l'état du classeur.
Vous avez modifié la 10 tbl = Array("Sheets1", "Sheets2","Sheets3") et mis en commentaire les lignes 15 et 16
Cela signifie que le classeur doit avoir des feuilles nommées "Sheets1", "Sheets2","Sheets3" et que les tables doivent commencer en cellule A1 dans chacune de ces feuilles

J'ai refait les tests avec les mêmes conditions et je n'ai pas de souci

Oui c'est bien cela, mon classeur a des feuilles nommées "Sheets1", "Sheets2","Sheets3" et les tables commencent toutes en cellule A1.
J'ai fait un test avec le fichier de démo et si je supprime les données à partir de la ligne 2 de l'onglet "Février 2013" alors j'obtiens la même erreur.