Discussion :

[Harkebe]

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.

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
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.

[MarcelG]

Bonjour Harkebe et bienvenu sur le Forum,

Le compteur i n'est pas utilisé dans le bloc For.. Next
D'autre part:
- Plutôt que de considérer - dangereusement - les cellules utilisées, préférer la définition de la plage à copier.
- Tu devrais effectuer ta copie en bloc, par plage de la 1ère cellule en haut à gauche à la dernière en bas à droite. Celle-ci étant - trivialement - définie par

Code :

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

Cells(derligne, dercolonne)

Ceci en sachant aussi que la cellule de destination sera décalée du nombre de lignes copiées.

Pourrai-tu essayer de développer en ce sens, procéder à un essai et revenir.
Je te conseillerais d'observer d'abord la copie manuelle sur le tableur, pour 1 ou 2 fichiers, puis de te pencher sur le code.

Au niveau de débutant, ce code peut être satisfaisant.
Notre ami doit être bien rigoureux dans les méthodes utilisées.

Une autre solution aurait été de compléter un tableau à 2 dimensions pour chaque fichier, à l'aide d'une fonction SommeTablo, que je reporterai à toute fin utile.

Code :

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

MonTablo = SommeTablo(MonTablo, tablofichier)

En fin de boucle, la plage de destination serait égale à la transposition du tableau final MonTablo

[Harkebe]

Bonjour Marcel et merci pour votre réponse!

Je vais essayer d'appliquer ce que vous me dites, mais ça risque de me prendre un peu de temps, je reviendrai une fois cela fait.

[MarcelG]

Salut,

Pour t'aiguiller
- Définition de la cellule de destination sur le classeur récipiendaire
Set dest = Range(...
- Ouverture en boucle des fichiers
- Pour chacun, définition de la plage à copier et copie

Code :

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

.Range("A2", .Cells(derligne,dercol).Copy Destination:=dest

- Annulation du mode copy

Code :

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

Application.Cutcopymode = False

- Fermeture du fichier annexe sans sauvegarde

Code :

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

.Close Savechanges:=False

- Redéfinition de la cellule de dstination

Code :

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

Set dest = dest.Offset(derligne-1,0)

(bien évidemment à adapter)

Attention de bien rattacher tes objets Range à leur feuille Parent par un "." en utilisant éventuellement le bloc With..End With

[Harkebe]

Enfin ça y est, ça marche!

Merci beaucoup Marcel pour votre aide précieuse, vous m'avez sacrément mâché le travail je dois le reconnaître.
Il ne me reste plus qu'à trouver un moyen de supprimer les en-tête et données inutiles après la premières copie (ou après toutes les copies je verrais).

Je laisse le code en bas si jamais ça peut aider d'autres personnes. Topic résolu.

Merci encore Marcel pour votre aide, et au plaisir de vous revoir.

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
Public Sub Test()
 
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
 
' 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)
 
    dercol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    derlig = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
 
    wbk.Worksheets(1).Range(Cells(1, 1), Cells(derlig, dercol)).Copy Destination:=dst
 
    Application.CutCopyMode = False
    wbk.Close SaveChanges:=False
 
    With res.Worksheets(1)
        Set dst = dst.Offset(derlig - 1, 0)
    End With
 
  End If
Next fic
 
End Sub

[MarcelG]

Salut Harkebe,

Tant que le code ne donne pas pleine satisfaction, il te faut y retourner.

Plusieurs remarques:

1 - Pour les définitions de dernière ligne et dernière colonne, tu proscris les méthodes SpecialCells et UsedRange.
Il peut toujours y avoir une mise en forme, un espace qui puisse t'induire en erreur.
Pour ce faire
- la bonne vieille méthode End(xl..) dont la génération d'erreur est rarissime
- la méthode qui consiste à trouver un caractère depuis le bas/la droite de la feuille (en sens inverse donc) (méthode Patrick)

2 - Pour accentuer la lisibilité du code, ne pas hésiter à utiliser le bloc With

Code :

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

1
2
3
With wbk.Worksheets(1).
 .Range(.Cells(1, 1), .Cells(derlig, dercol)).Copy Destination:=dst
End With

Tu remarqueras les '." nécessaires au rattachement - fondamental - des objets Range.

3 - Si la 1ère ligne de chaque fichier est affectée aux titres des champs, alors une variable de l'objet Cells(1,1) serait à changer.
Je te laisse trouver.

4 - Il est de bon aloi de libérer les variables affectées aux objets (Set...) après utilisation en commençant par la dernière.

Code :

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

Set lavariable = Nothing

Tu reviens en ayant adapté ces remarques.