Une macro pour recopier des lignes suivant une valeur dans une cellule

**Ragnart** · 28/04/2019, 13h57

Bonjour à tous
J'ai besoin d'aide pour recopier des lignes dans d'autres onglets à l'aide d'une macro, mais je n'y arrive pas
J'ai joins un modèle de fichier (j'ai supprimé tous les noms et toutes les macros pour plus de facilité)
voici ce que j'aimerai faire :

Dans l'onglet Gestion gardiens j'aimerai que lorsque j'inscris Agent1 en colonne C ou G dans lieu 1 en C3
ça me recopie dans l'onglet Agent1 la ligne correspondante dans lieu1 les colonnes A, C, D, E, F, G, H, I, J de gestion gardiens)

Si j'inscris Agent 1 colonne S ou colonne W dans lieu 3 case S3
ça me recopie la ligne dans l'onglet Agent1 lieu 3

Idem pour Agent2 et agent3 à recopier dans les onglets Agent2 et Agent3

J'espère que j'ai réussi à m'expliquer. merci à toutes celles et tous ceux qui pourront m'apporter un élément de réponse
planning gardiens.xlsm

**EricDgn** · 29/04/2019, 22h07

Bonjour,

Une façon de faire: insérer ce code dans la feuille 'Gestion gardiens'.

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
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sAgt As String, kR As Long, kC As Long
    sAgt = Target.Value
    If Evaluate("ISREF(" & sAgt & "!A1)") = False Then
        MsgBox "Pas encore d'onglet '" & sAgt & "' créé!", , "Pour info"
        Exit Sub
    End If
    With ActiveWorkbook.Worksheets(sAgt)
        kR = Target.Row
        kC = Target.Column
        '--- recopie les données aux mêmes places
        .Cells(kR, 1) = Cells(kR, 1).Value              '--- date
        .Cells(kR, kC) = Cells(kR, kC).Value            '--- agent
        .Cells(kR, kC + 1) = Cells(kR, kC + 1).Value    '--- heure début
        .Cells(kR, kC + 2) = Cells(kR, kC + 2).Value    '--- heure fin
        .Cells(kR, kC + 3) = Cells(kR, kC + 3).Value    '--- total
    End With
End Sub

Cela ne vérifie pas que rien n'est écrasé dans l'onglet de l'agent, et n'efface rien si un changement d'agent est effectué.

Bonne continuation.

**Ragnart** · 30/04/2019, 07h50

Bonjour Ericdgn,

C'est exactement cela, votre code fonctionne à la perfection ! Je vous remercie vivement pour vous êtes penché sur mon problème. Vous allez me faire gagner un temps considérable.
Cela m'évite de recopier les heures de chacun pour les transmettre ensuite en comptabilité pour le paiement des salaires.
dire que je me suis cassé la tête durant des semaines, tous mes codes que je créés jusqu'à présent ne fonctionnaient pas ou partiellement.
Je suis encore légèrement novice dans les macros bien que je sache faire les plus courantes. Mille merci à vous !

Trop content !
Bien cordialement,

**Ragnart** · 08/05/2019, 11h00

Bonjour à tous,

EricDgn m'a beaucoup aidé avec son code pour recopier des lignes suivant une valeur et je le remercie encore !

Seulement, quand je veux effacer une ou des cellules, j'ai chaque fois un code d'erreur qui s'affiche : erreur d'exécution "13" incompatibilité de type

J'ai tenté des solutions sans succès, quelqu'un aurait une idée pour que ce code d'erreur ne s'affiche plus ?
Merci d'avance

**EricDgn** · 08/05/2019, 13h19

Bonjour,

Oui, j'avais signalé cela:

Cela ne vérifie pas que rien n'est écrasé dans l'onglet de l'agent, et n'efface rien si un changement d'agent est effectué.

Pour remédier à cela, et prendre en compte les changements et suppression, ceci devrait convenir (à placer dans la feuille 'Gestion gardiens')

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
Option Explicit
Dim sAgtOld As String
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sAgt As String, kR As Long, kC As Long
    sAgt = Target.Value
    kR = Target.Row
    kC = Target.Column
    If sAgtOld = "" Then
        '--- cellule était vide, rien à faire
    Else
        Effacer sAgtOld, kR, kC     '--- efface ancienne affectation
    End If
    If sAgt <> "" Then
        If Evaluate("ISREF(" & sAgt & "!A1)") = False Then
            MsgBox "Pas encore d'onglet '" & sAgt & "' créé!", , "Pour info"
            Target.Value = ""       '--- annule agent sélectionné
        Else
            Copier sAgt, kR, kC     '--- copie affectation
        End If
    End If
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    sAgtOld = Target.Value
End Sub
 
Private Sub Effacer(sAgt As String, kR As Long, kC As Long)
    With ActiveWorkbook.Worksheets(sAgt)
        '--- vider les données aux mêmes places, sauf la date
        .Cells(kR, kC) = ""                             '--- agent
        .Cells(kR, kC + 1) = ""                         '--- heure début
        .Cells(kR, kC + 2) = ""                         '--- heure fin
        .Cells(kR, kC + 3) = ""                         '--- total
    End With
End Sub
 
Private Sub Copier(sAgt As String, kR As Long, kC As Long)
    With ActiveWorkbook.Worksheets(sAgt)
        '--- recopie les données aux mêmes places
        .Cells(kR, 1) = Cells(kR, 1).Value              '--- date
        .Cells(kR, kC) = Cells(kR, kC).Value            '--- agent
        .Cells(kR, kC + 1) = Cells(kR, kC + 1).Value    '--- heure début
        .Cells(kR, kC + 2) = Cells(kR, kC + 2).Value    '--- heure fin
        .Cells(kR, kC + 3) = Cells(kR, kC + 3).Value    '--- total
    End With
End Sub

A noter, dans ce dispositif il faut toujours inscrire les horaires avant d'inscrire un gardien. Les modifications d'horaire ne sont pas "recopiées" d'elles-même.

Maintenant, par principe ce n'est pas une bonne solution de faire des "copiages" de données. Il vaudrait beaucoup mieux disposer les données de façon à pouvoir créer un tableau croisé dynamique.

Bonne continuation.

**Ragnart** · 08/05/2019, 15h57

ça fonctionne à merveille, je vous remercie énormément. j'ai un peu aménagé le code à mes tableaux de recopie, sans vous je n'y serait jamais parvenu.
pour les tableaux croisé dynamique je me suis inscrit à mon travail, il y a des cours Excel sur les tableaux croisé dynamique, je suis complètement ignorant dans ce domaine.
votre m'est précieuse et me font gagner énormément de temps.
Bien cordialement et merci encore