Macro VBA automatique/Copie de lignes

Version imprimable

Bonjour à tous.
Je souhaiterais améliorer une macro que j'ai réalisée en faisant quelques petites retouches. J'y travaille depuis un moment mais je ne parviens pas à réaliser ce que je souhaite.
Mon fichier va piocher dans les différents fichiers Excel d'un même sous-dossier pour les fusionner. Certains onglets sont alors en double. Le contenu d'un des deux onglets (moins les trois premières lignes présentant le nom des différentes colonnes du tableau) est alors copié dans l'autre, et le "doublon" est ensuite détruit.

Je cherche à améliorer plusieurs choses :
1) En travaillant un peu plus mon fichier, je souhaitais créer un onglet "Tous" rassemblant l'intégralité des lignes de tous les autres onglets. J'ai rajouté quelques lignes en bout de macro, mais petit problème : lorsqu'un onglet ne contient pas de lignes autres que les trois premières (qui ne m'intéressent pas puisqu'elles rassemblent le nom des colonnes), celles-ci sont tout de même copiées à la suite des lignes de mon onglet "Tous".
Les lignes suivantes permettent de copier ce qui provient du doublon et de détruire le doublon ensuite.

Code:

1
2
3
4
5
6
7
8
 
Set DEST = IIf(Sheets("DIJON").Range("A1") = "", Sheets("DIJON").Range("A1"), Sheets("DIJON").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
DEST.CurrentRegion.Interior.Color = RGB(0, 191, 255)
Sheets("DIJON (2)").Range("A4:AV" & Sheets("DIJON (2)").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Application.DisplayAlerts = False
Worksheets("DIJON (2)").Delete
Application.DisplayAlerts = True

2) Il existe aussi une ligne de code me permettant de colorer les lignes du tableau provenant du doublon. Sauf que celle-ci colore aussi les lignes présentant les intitulés des colonnes (les fameuses trois premières lignes). Je préférerais qu'elles ne soient pas colorées). Je pense qu'il y a une multitude de méthodes mais je ne parviens pas trop à comprendre la manière de sélection adéquate pour y parvenir.

3)Je souhaiterais que l'execution de la macro soit réalisé non pas à l'appui d'un bouton dans un des onglets du fichier, mais à l'ouverture de la macro. Le problème, c'est que je ne sais pas comment dépouiller le fichier fabriqué par la macro de toute macro justement, afin que celle ci ne se ré exécute pas automatiquement dès qu'on clique sur le fichier fabriqué (ai-je été clair ?).

Voici l'intégralité du code :

Code:

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
 
Sub PROCEDURE()
 
Dim CM As Workbook 'Classeur Maître
Dim CS As Workbook 'Classeur Source
Dim K As Byte
 
ChDir ActiveWorkbook.Path
Set CM = ActiveWorkbook
 
nf = Dir("*.xls")
Do While nf <> ""
    If nf <> CM.Name Then
        Workbooks.Open Filename:=nf
        Set CS = ActiveWorkbook
        For K = 1 To CS.Sheets.Count
            CS.Sheets(K).Copy After:=CM.Sheets(CM.Sheets.Count)
        Next K
        CS.Close False
    End If
    nf = Dir
Loop
 
Dim DEST As Range
 
Set DEST = IIf(Sheets("PACA").Range("A1") = "", Sheets("PACA").Range("A1"), Sheets("PACA").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
DEST.CurrentRegion.Interior.Color = RGB(0, 191, 255)
Sheets("PACA (2)").Range("A4:AV" & Sheets("PACA (2)").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Application.DisplayAlerts = False
Worksheets("PACA (2)").Delete
Application.DisplayAlerts = True
 
Set DEST = IIf(Sheets("DIJON").Range("A1") = "", Sheets("DIJON").Range("A1"), Sheets("DIJON").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
DEST.CurrentRegion.Interior.Color = RGB(0, 191, 255)
Sheets("DIJON (2)").Range("A4:AV" & Sheets("DIJON (2)").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Application.DisplayAlerts = False
Worksheets("DIJON (2)").Delete
Application.DisplayAlerts = True
 
Set DEST = IIf(Sheets("LYON").Range("A1") = "", Sheets("LYON").Range("A1"), Sheets("LYON").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
DEST.CurrentRegion.Interior.Color = RGB(0, 191, 255)
Sheets("LYON (2)").Range("A4:AV" & Sheets("LYON (2)").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Application.DisplayAlerts = False
Worksheets("LYON (2)").Delete
Application.DisplayAlerts = True
 
Set DEST = IIf(Sheets("MR_MFA").Range("A1") = "", Sheets("MR_MFA").Range("A1"), Sheets("MR_MFA").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
DEST.CurrentRegion.Interior.Color = RGB(0, 191, 255)
Sheets("MR_MFA (2)").Range("A4:AV" & Sheets("MR_MFA (2)").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Application.DisplayAlerts = False
Worksheets("MR_MFA (2)").Delete
Application.DisplayAlerts = True
 
Set DEST = IIf(Sheets("Mal formaté").Range("A1") = "", Sheets("Mal formaté").Range("A1"), Sheets("Mal formaté").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
DEST.CurrentRegion.Interior.Color = RGB(0, 191, 255)
Sheets("Mal formaté (2)").Range("A4:AV" & Sheets("Mal formaté (2)").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Application.DisplayAlerts = False
Worksheets("Mal formaté (2)").Delete
Application.DisplayAlerts = True
 
Application.DisplayAlerts = False
Worksheets("F").Delete
Application.DisplayAlerts = True
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("PACA").Range("A4:AV" & Sheets("PACA").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("DIJON").Range("A4:AV" & Sheets("DIJON").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("LYON").Range("A4:AV" & Sheets("LYON").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("Mal formaté").Range("A4:AV" & Sheets("Mal formaté").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("MR_MFA").Range("A4:AV" & Sheets("MR_MFA").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("Paris Sud Est").Range("A4:AV" & Sheets("Paris Sud Est").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("CHAMBERY").Range("A4:AV" & Sheets("CHAMBERY").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("MONTPELLIER").Range("A4:AV" & Sheets("MONTPELLIER").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Set DEST = IIf(Sheets("Tous").Range("A1") = "", Sheets("Tous").Range("A1"), Sheets("Tous").Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
Sheets("Paris rive gauche").Range("A4:AV" & Sheets("Paris rive gauche").Cells(Application.Rows.Count, "A").End(xlUp).Row).Copy DEST
 
Dim Path As String, valeur As String
Path = ActiveWorkbook.Path & "\"
valeur = "CS_ FUSION_" & Format(Date, "dd_mm_yyyy") & "_" & ".xlsm"
ThisWorkbook.SaveAs Path & valeur
 
Application.Quit
 
End Sub

Bonjour Sikanda, bonjour le forum,

• Pour ton premier problème. Place la macro ci-dessous dans un module standard (Module1 par exemple) :

Code:

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
Sub Macro1()
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Integer 'déclare la variable I (Incrément)
 
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set OD = Sheets("TOUS") 'définit l'onglet de destination OD (génère une erreur si c'est onglet n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'efface l'erreur
    Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un nouvel onglet en dernière position
    ActiveSheet.Name = "Tous" 'renomme l'onglet
    Set OD = ActiveSheet 'définit l'onglet de destination OD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Sheets(1).Rows(1 & ":" & 3).Copy 'copies les 3 premières lignes du premier onglet du classeur
OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle dans A1 de l'onglet OD la largeur des colonnes
Sheets(1).Rows(1 & ":" & 3).Copy OD.Range("A1") 'copie les 3 premières lignes du premier onglet du classeur et les colle dans A1 de l'onglet OD
For I = 1 To Sheets.Count 'boucle sur tous les onglets I du classeur
    If Not Sheets(I).Name = "Tous" Then 'condition 1 : si le nom de l'onglet n'est pas "Tous"
        Set PL = Sheets(I).Range("A1").CurrentRegion 'définit la plage PL
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        'refédinit la plage PL sans les 3 premières lignes (génere une erreur si il n'existe pas de données au-dela de la troisième ligne)
        Set PL = PL.Offset(3, 0).Resize(PL.Rows.Count - 3, PL.Columns.Count)
        If Err <> o Then 'condition 2 : si une erreur a été générée
            Err.Clear 'efface l'erreur
            GoTo suite 'va à l'étiquette "suite"
        End If 'fin de la condition 2
        On Error GoTo 0 'annule la gestion des erreurs
        Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
        PL.Copy DEST 'copie la plage PL dans DEST
        Set PL = Nothing 'réinitialise la plage PL
    End If 'fin de la condition 1
suite: 'étiquette
Next I 'prochain onglet de la boucle
OD.Select 'sélectionne l'onglet de destination OD
Range("A1").Select 'sélectionne la cellule A1 de l'onglet OD
End Sub

• Dans le composant ThisWorkbook le code qui suit (à adapter selon l'emplacement du premier code) :

Code:

1
2
3
Private Sub Workbook_Open()
Module1.Macro1 'lance la procédure [marco1] du module [Module1]
End Sub

29/07/2015, 16h25
Sikanda

J'ai testé, et ça fonctionne partiellement, j'ai encore des copies des trois premières lignes par endroits.
En fait, cette feuille "Tous" possède elle-même l'en tete avec les trois lignes de présentation des colonnes. Cette ligne là est détruite à chaque fois que j'ouvre le fichier excel. D'autre part dans le fichier "Tous", j'ai 1283 lignes au lieu de 652.
Je regarde plus précisément pourquoi ça déconne d'ici demain.
29/07/2015, 16h31
Thautheme

Re,

Le code peut dysfonctionner si, dans un onglet, le tableau ne commence pas à la ligne 1. Mais sans le fichier j'ai fait un plus simple...
30/07/2015, 09h35
Sikanda

3 pièce(s) jointe(s)

Les fichiers sont tous placés dans le même dossier. La macro du fichier de fusion permet de créer un autre fichier qui est la fusion des deux dans le même dossier.

1 pièce(s) jointe(s)

Bonjour Sikanda, bonjour le forum,

J'ai refait ta première macro avec le code ci-dessous :

Code:

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
Sub PROCEDURE()
Dim NF As String 'déclare la variable NF (Nouveau Fichier)
Dim CM As Workbook 'déclare la variable CM (Classeur Maître)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim K As Byte 'déclare la variable K (incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)
Dim O As Worksheet 'déclare la variable O (Onglets)
Dim OT As Worksheet 'déclare la variable OT (Onglet de Travail)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim Valeur As String 'déclare la variable Valeur
 
ChDir ActiveWorkbook.Path 'définit le dossier de travail
Set CM = ActiveWorkbook 'définit le classeur maître CM
NF = Dir("*.xls") 'définit le nouveau fichier NF (premier fichier du dossier de travail)
Do While NF <> "" 'boucle tant qu'il existe des nouveeaux fichiers
    If InStr(1, NF, CM.Name, vbTextCompare) = 0 Or NF <> CM.Name Then 'condition 1 : si le nom du nouveau fichier n'est pas contenu dans le nom du classeur maître ou si il est différent
        Workbooks.Open Filename:=NF 'ouvre le nouveau fichier
        Set CS = ActiveWorkbook 'définit le classeur source CS
        For K = 1 To CS.Sheets.Count 'boucle sur tous les onglet du classeur source
            On Error Resume Next 'gestion des erreur (en cas d'erreur passe à la ligne suivante)
            Set OS = CM.Sheets(CS.Sheets(K).Name) 'définit l'onglet source (génère une erreur si cet onglet n'existe pas dans le classeur maître)
            If Err <> 0 Then 'condition 2 : si une ereur a été générée
                Err.Clear 'efface l'erreur
                CS.Sheets(K).Copy After:=CM.Sheets(CM.Sheets.Count) 'copie l'onglet K du classeur source en dernière position du classeur maître
                Set OS = ActiveSheet 'définit l'ouglet source OS
                GoTo suite 'va 'à l'étiquette "suite"
            End If 'fin de la condition
            On Error GoTo 0 'annule la gestion des erreurs
            Set DEST = OS.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellue de destination DEST
            If CS.Sheets(K).Range("A4").Value <> "" Then 'c0ndition 3 : si la cellule A4 de l'onglet de la boucle du classeur source n'est pas vide
                Set PL = CS.Sheets(K).Range("A1").CurrentRegion 'définit la plage PL
                Set PL = PL.Offset(3, 0).Resize(PL.Rows.Count - 3, PL.Columns.Count) 'redéfinit la palge PL (dans les 3 première lignes)
                PL.Copy DEST 'copie la plage PL dans DEST
                Set PL = Nothing 'réinitialise PL
                Set DEST = Nothing 'réinitialise DEST
            End If 'fin de la condition 3
suite: 'étiquette
        Next K 'prochain onglet de la boucle
        CS.Close False 'ferme le classeur source sans enregistrer
    End If 'fin de la condition 1
    NF = Dir 'redéfinit NF (prochain fichier du dossier de travail)
Loop 'boucle tant qu'il existe des fichiers
Module2.Macro1 'lance la macro [Macro2] du module [Module2]
CA = ActiveWorkbook.Path & "\" 'définit le chemin d'accès CA
Valeur = "CS_ FUSION_" & Format(Date, "dd_mm_yyyy") & "_" & ".xlsm" 'définit la variable Valeur
ThisWorkbook.SaveAs CA & Valeur 'enregistre le classeur sous...
End Sub

Et remanié la mienne avec les corrections ci-dessous :

Code:

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
Sub Macro1()
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Integer 'déclare la variable I (Incrément)
 
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set OD = Sheets("Tous") 'définit l'onglet de destination OD (génère une erreur si c'est onglet n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'efface l'erreur
    Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un nouvel onglet en dernière position
    ActiveSheet.Name = "Tous" 'renomme l'onglet
    Set OD = ActiveSheet 'définit l'onglet de destination OD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Sheets(Sheets.Count).Rows(1 & ":" & 3).Copy 'copies les 3 premières lignes du dernier onglet du classeur
OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle dans A1 de l'onglet OD la largeur des colonnes
Sheets(Sheets.Count).Rows(1 & ":" & 3).Copy OD.Range("A1") 'copie les 3 premières lignes du dernier onglet du classeur et les colle dans A1 de l'onglet OD
For I = 1 To Sheets.Count 'boucle sur tous les onglets I du classeur
    If Not Sheets(I).Name = "Tous" Or Not Sheets(I).Name = "F" Then 'condition 1 : si le nom de l'onglet n'est pas "Tous"
        Set PL = Sheets(I).Range("A1").CurrentRegion 'définit la plage PL
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        'refédinit la plage PL sans les 3 premières lignes (génere une erreur si il n'existe pas de données au-dela de la troisième ligne)
        Set PL = PL.Offset(3, 0).Resize(PL.Rows.Count - 3, PL.Columns.Count)
        If Err <> O Then 'condition 2 : si une erreur a été générée
            Err.Clear 'efface l'erreur
            GoTo suite 'va à l'étiquette "suite"
        End If 'fin de la condition 2
        On Error GoTo 0 'annule la gestion des erreurs
        Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
        PL.Copy DEST 'copie la plage PL dans DEST
        Set PL = Nothing 'réinitialise la plage PL
    End If 'fin de la condition 1
suite: 'étiquette
Next I 'prochain onglet de la boucle
OD.Select 'sélectionne l'onglet de destination OD
Range("A1").Select 'sélectionne la cellule A1 de l'onglet OD
End Sub

Ça semble fonctionner...

30/07/2015, 16h22
Sikanda

En effet, ça fonctionne, très bien même. :) Merci.
Du coup je vais tenter de raccorder ça avec ce que le code de base concernant l'ajout de couleurs histoire de faire quelque chose de propre :)