Copier un onglet dans le même classeur sans le code VBA de la feuille source

**goninph** · 28/08/2019, 17h46

Bonjour,

Comment copier un onglet dans le même classeur sans le code VBA de la feuille copiée ?

Merci pour votre aide
Meilleures salutations
Philippe

**Menhir** · 28/08/2019, 18h24

S'il n'y a rien de trop compliqué dans la feuille source (référence externes, cellules fusionnées, etc.), tu peux copier le contenu.

Créer une nouvelle feuille > sélectionner toutes les colonnes de la source > Ctrl+C > Sélectionner A1 de la nouvelle feuille > Ctrl+V

En VBA

Code :

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

1
2
3
Dim WSDest As Worksheet
Set WSDest = Worksheets.Add
Worksheets("Source").UsedRange.EntireColumn.Copy WSDest.Range("A1")

Sinon, il faut copier la feuille et supprimer le contenu.
A la main, ça ne prends que quelques secondes.
En VBA, c'est plus compliqué (perso, je m'interdis d'aller tripatouiller dans le VBE par macro).

**Philippe Tulliez** · 28/08/2019, 18h47

Bonjour,
Si le code de la feuille est une procédure événementielle il est possible d'utiliser la procédure événementielle correspondante (événement préfixé Sheet) à placer dans ThisWorkbook
Ainsi pour intercepter l'événement Change d'une feuille, on peut utiliser indifféremment la procédure Worksheet_Change(ByVal Target As Range) ou Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range). Il y a lieu pour cette dernière de tester l'objet sh en plus de Target

**goninph** · 28/08/2019, 19h22

Bonjour,

Merci merci et merci. vous êtes trop fort

Le code est correct pour le test de la feuille ?

Meilleures salutations
Philippe

Avec Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Code :

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

1
2
3
4
5
6
7
8
Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Code déplacer dans ThisWorkbook pour ne pas copier le code dans la feuille planning
 
If ActiveSheet.Name = ("PV de chantier") Then
        MsgBox "Vous êtes trés fort. MERCI"
    End If
End Sub

Envoyé par Philippe Tulliez

Bonjour,
Si le code de la feuille est une procédure événementielle il est possible d'utiliser la procédure événementielle correspondante (événement préfixé Sheet) à placer dans ThisWorkbook
Ainsi pour intercepter l'événement Change d'une feuille, on peut utiliser indifféremment la procédure Worksheet_Change(ByVal Target As Range) ou Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range). Il y a lieu pour cette dernière de tester l'objet sh en plus de Target

**Philippe Tulliez** · 29/08/2019, 13h06

Bonjour,

Le code est correct pour le test de la feuille ?

Même s'il est évident que cet événement a lieu dans la feuille active, je préfère effectuer le test à l'aide de la variable objet sh.

**goninph** · 29/08/2019, 19h31

Bonjour,

C'est à dire... J'ai pas tout compris les subtilités.

Merci et meilleures salutations
Philippe

Envoyé par Philippe Tulliez

Bonjour,

Même s'il est évident que cet événement a lieu dans la feuille active, je préfère effectuer le test à l'aide de la variable objet sh.

**goninph** · 30/08/2019, 11h38

Bonjour,

J'ai un problème suite à cette modification.

Sur tous les onglets, le tri par ordre alphabétique via les filtres automatiques ne fonctionnent plus correctement.
Après avoir appliqué le filtre je dois cliquer n'importe où dans la feuille pour rendre actif le filtre.

Qui peut m'aider ?

Merci et meilleures salutations
Philippe

**Philippe Tulliez** · 30/08/2019, 18h41

Bonjour,
Pour donner un coup de main, il faudrait voir le code de cette procédure.

**goninph** · 08/09/2019, 09h19

J'ai trouvé, j'avais oublié de remettre Application.ScreenUpdating = True

Merci à tous et bon dimanche
Philippe

Envoyé par goninph

Bonjour,

J'ai un problème suite à cette modification.

Sur tous les onglets, le tri par ordre alphabétique via les filtres automatiques ne fonctionnent plus correctement.
Après avoir appliqué le filtre je dois cliquer n'importe où dans la feuille pour rendre actif le filtre.

Qui peut m'aider ?

Merci et meilleures salutations
Philippe

**goninph** · 31/08/2019, 08h34

voilà dans ThisWorkbook

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
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
Option Explicit
Dim LigneCelluleActive As Variant
Dim Colonne_A As Variant
Dim Colonne_E As Variant
Dim Colonne_V As Variant
Dim Colonne_BE As Variant
'Sauvegarde une copie du fichier nommé: Date & la date, dans un dossier, dans le même dossier du fichier, nommé: Backup & le nom du fichier
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim chemin As String
Dim CheminSource As String
Dim CheminBackup As String
Dim DossierBackup As String
Dim CheminPublic As String
Dim MonFichier As String
Dim Nom As String
Dim NomMajuscule As String
    Nom = Environ("USERNAME")
    NomMajuscule = UCase(Nom) 'UCase = Mise en majuscule - LCase = minuscule - Application.proper = Nom propre
    DossierBackup = "Backup " & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) 'Pour enlever le .xlsm les 5 caractères depuis la droite
    CheminSource = ThisWorkbook.Path & "\" & DossierBackup & "\"
'Test si le dossier existe déjà
On Error Resume Next 'N'éxécute pas la ligne qui suit en cas d'erreur
       MkDir CheminSource
On Error GoTo 0 'Ressort de l'erreur qui permet de nouvelles erreurs
    chemin = CheminSource
'Sauvegarde d'une copie du fichier avec la date
        ActiveWorkbook.SaveCopyAs chemin & Format(Now(), "YYYY.MM.DD hh-mm-ss ") & NomMajuscule & " " & ThisWorkbook.Name
End Sub
Private Sub Workbook_Open()
    Sheets("PV de chantier").Select
        Application.DisplayFullScreen = True ' Affichage plein écran
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Code déplacer dans ThisWorkbook pour ne pas copier le code dans la feuille planning
Dim Numero_du_CFC As Variant
Dim Ligne_Insertion As Variant
Dim Cell_nouvelle_ligne As Variant
Dim Adresse_colonne_A As Variant
    Application.ScreenUpdating = False ' Désactive le changement des pages à l'écran lors de l'éxécution de la macro
If ActiveSheet.Name = ("PV de chantier") Then
On Error GoTo Fin
'Colonne B
        If Not Intersect([B50:B10000], Target) Is Nothing And Target.Count = 1 Then
                Adresse_colonne_A = ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Address
'        Masquer la ligne dans le planning
            If Range(Adresse_colonne_A).Value Like "*20002" Then
                If MsgBox("Afficher cette ligne dans le planning ?", vbYesNo + vbQuestion, "Contact") = vbYes Then
                        ActiveCell.Value = "P"
                    With Selection.Font
                        .Color = -16744448 'Couleur de police verte pour le vu
                    End With
                        ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Select
                    Else
                        ActiveCell.Value = ""
                        ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Select
                    End If
                End If
                End If
            If Not Intersect([Celle_date_debut_planning], Target) Is Nothing And Target.Count = 1 Then
                MsgBox "La modification de cette date déplacera toutes les dates du planning.", vbExclamation, "! IMPORTANT !"
                End If
            If Not Intersect([D50:D10000], Target) Is Nothing And Target.Count = 1 Then
                If ActiveCell.Value = "CFC" Then
                    Inserer_lignes_CFC.Inserer_ligne_pour_nouveau_CFC
                End If
        End If
'Colonne C
        If Not Intersect([C50:C10000], Target) Is Nothing And Target.Count = 1 Then
            If ActiveCell <> "" Then
                USF_Filtre_CFC.Show
            End If
        End If
'Colonne D
        If Not Intersect([D50:D10000], Target) Is Nothing And Target.Count = 1 Then
                Adresse_colonne_A = ActiveCell.Offset(rowOffset:=0, columnOffset:=-3).Address
                Numero_du_CFC = ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Value
        'Insérer une ligne pour un nouveau contact en dessous de la sélection
                If Range(Adresse_colonne_A).Value Like "*10002" Then 'Si la cellule de la colonne A se termine par alors on ajoute une ligne de texte au PV du CFC
                    If MsgBox("Inserer une nouvelle ligne contact au " & Numero_du_CFC, vbYesNo + vbQuestion, "Editer le PV") = vbYes Then
                        Inserer_ligne_Contacts.InsererLigneContacts
                    End If
                End If
        'Insérer une ligne de texte au PV en dessous de la sélection
                If Range(Adresse_colonne_A).Value Like "*20002" Then 'Si la cellule de la colonne A se termine par 200 alors on ajoute une ligne de texte au PV du CFC
                    If MsgBox("Inserer une nouvelle ligne au " & Numero_du_CFC, vbYesNo + vbQuestion, "Editer le PV") = vbYes Then
                        Inserer_ligne_texte_PV.InsererLigneTextePV
                End If
            End If
        End If
'Colonne E
        If Not Intersect([E50:E10000], Target) Is Nothing And Target.Count = 1 Then
                Adresse_colonne_A = ActiveCell.Offset(rowOffset:=0, columnOffset:=-4).Address
        'Insérer un nouveau CFC si la cellule est vide
                If ActiveCell.Value = "" Then
                    If ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Value = "CFC" Then
                        Inserer_lignes_CFC.Inserer_nouveau_Numero_CFC
                    End If
                End If
        'Editer entreprise du CFC
                    If Range(Adresse_colonne_A).Value Like "*10001" Then 'Si la cellule de la colonne du CFC se termine par alors
                        If MsgBox("Modifier l'entreprise du CFC ?", vbYesNo + vbQuestion, "Editer le PV") = vbYes Then
                            If ActiveCell.Offset(rowOffset:=0, columnOffset:=11) = "" Then
                                Search_Entreprises.Show
                            Else
                                USF_Modifier_Entreprise_CFC.Show
                        End If
                    End If
                End If
        'Editer le contact
                    If Range(Adresse_colonne_A).Value Like "*10002" Then 'Si la cellule de la colonne du CFC se termine par alors
                        If ActiveCell = "" Then
                            If MsgBox("Ajouter une personne de contact ?", vbYesNo + vbQuestion, "Editer le PV") = vbYes Then
                                Search_Contact.Show
                                USF_Modifier_texte_contact.Show
                        End If
                            Else
                                USF_Modifier_texte_contact.Show
                    End If
                End If
        'Editer le texte du PV
                If Range(Adresse_colonne_A).Value Like "*20002" Then 'Si la cellule de la colonne du CFC se termine par alors
                    USF_Modifier_texte_PV.Show
                End If
        End If
'Plage de F à J
            Colonne_A = 1
            Colonne_E = 5
            Colonne_V = 22
                If Not Intersect([F50:J10000], Target) Is Nothing And Target.Count = 1 Then
                LigneCelluleActive = ActiveCell.Row
                Adresse_colonne_A = Cells(LigneCelluleActive, Colonne_A).Address
        'Editer le contact en cliquant sur la colonne F
                If Range(Adresse_colonne_A).Value Like "*10002" Then
                        Cells(LigneCelluleActive, Colonne_E).Select
                    End If
                'Editer le texte en cliquant sur la colonne F
                If Range(Adresse_colonne_A).Value Like "*20002" Then
                        Cells(LigneCelluleActive, Colonne_E).Select
                    End If
            End If
'Plage de U à V
            If Not Intersect([U50:V10000], Target) Is Nothing And Target.Count = 1 Then
                LigneCelluleActive = ActiveCell.Row
                Adresse_colonne_A = Cells(LigneCelluleActive, Colonne_A).Address
        'Liste de distribution du planning
                If Range(Adresse_colonne_A).Value Like "*10002" Then
                    If Cells(LigneCelluleActive, Colonne_E).Value = "" Then   'Si pas de contact
                        Cells(LigneCelluleActive, Colonne_E).Select           'Sélectionner la cellule du contact
                Exit Sub
                Else
                    Cells(LigneCelluleActive, Colonne_V).Select
                    USF_Distribution_planning.Show
                End If
            End If
        End If
'Plage de AS à BD pour ptotéger les formules
        Colonne_BE = 57
            If Not Intersect([AS49:BD10000], Target) Is Nothing And Target.Count = 1 Then
                LigneCelluleActive = ActiveCell.Row
        'Protection des formules
            If Sheets("DATA Divers").Range("Cell_Protection_Formule").Value <> "Formules déprotégées" Then
                Adresse_colonne_A = Cells(LigneCelluleActive, Colonne_A).Address
                    Cells(LigneCelluleActive, Colonne_BE).Select
                    MsgBox "La cellule sélectionnée est protégée"
              End If
        End If
'Plage entête du planning
        If Not Intersect([Planning_Date_Entete], Target) Is Nothing And Target.Count = 1 Then
            USF_Entete_Planning.Show
      End If
    End If
Fin:
End Sub

**Philippe Tulliez** · 31/08/2019, 10h14

Bonjour,
Il y a trop d'instructions à lire dans cette procédure événementielle pour comprendre ce qu'elle fait.
De plus d'après ma lecture rapide tu invoques deux UserForm, tu as des adressages de plages de cellules "Hard codée" comme par exemple [D50:F10000] (J'ai remplacé le D par F pour éviter l'émoticône)c'est personnellement une syntaxe pour adresser des cellules que je n'utilise jamais.
Tu aurais intérêt à bien découper les procédures en plus petite et vérifier que chacune d'elles fait son travail sans problème.

**goninph** · 01/09/2019, 15h29

Hello,

J'aimerai apprendre, quelle est ta méthode ?

Meilleures salutations
Philippe

Copier un onglet dans le même classeur sans le code VBA de la feuille source

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager