Copie de colonne sous condition et application d'un coefficient

**pryamani** · 17/06/2018, 18h23

Bonjour Qwaz,

Me revoilà sur une question dont je n'arrive point à trouver la solution.

est-il possible qu'au fur et à mesure que je saisie des heures d'enseignement aux enseignants, il y a un msgbox qui stoppe ma saisie dès lors que j'ai dépassé le maximum autorisé.

J'ai réussi à mettre en application cette fonction par une formule, le souci c'est que si l'on ne fait pas attention au résultat de cette formule, le risque est de vite dépasser le maximum autorisé

Je m'explique dans la maquette que je joins en colonne "G1" se trouve l'information "Maximum à ne pas dépasser pour les CM et en colonne "J7" se trouve l'information "Maximum à ne pas dépasser pour le TD"

Au fur et à mesure que je saisie un nombre pour CM1 que j'applique le coefficient de 1.5 (macro mise en place) si je ne dépasse pas le maximum autorisé je continu CM2 coeff applliqué, puis le CM3 coeff appliqué etc... dès lors que je dépasse le max autorisé en saisissant le nombre d'heure coeff appliqué, un msgbox m'interdit toute saisie. Je ne peux plus rien faire si ce n'est revoir la distribution des Heures.

C'est le même principe pour les TD

La particularité c'est que mon tableau fait 74 lignes et 39 colonnes est que la fonction ci-dessus doit s'appliquer pour chaque ligne (Max CM et Max TD qui change à chaque ligne)

en résumé : CM1 (coeff de 1.5 appliqué) + CM2 (coeff de 1.5 appliqué) = tant que le total n'a pas dépassé le Max CM autorisé, je continue dès que le MAXCM est dépassé Msgbox apparaît et je ne peu plus rien faire

J'ai vu les cours mais aucun qui traite ma demande bien spécifique

Merci de ce que tu pourras me conseiller

Pièce jointe 389255

**Qwazerty** · 17/06/2018, 22h00

Salut

Plutôt que de tout bloquer, tu peux calculer à l'avance si l'application du coéf va provoquer le dépassement des quotas. Ça donnerait un code comme ça.

Attention dans le tableau, j'ai modifié le nom de la colonne CM répartis, il y avait un espace après CM que j'ai retiré.

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
Sub Positif()
Dim iOffset As Byte
Dim Plage As Range, Cel As Range, CellOff As Range
Dim TotalCM As Double
 
'On pointe les cellule de la colonne T
Set Plage = Feuil1.ListObjects("Tab_Base").ListColumns("CM1").DataBodyRange
 
'On recherche le nombre de colonne CM à tester
iOffset = Feuil1.ListObjects("Tab_Base").ListColumns.Count
iOffset = iOffset - Plage.Column
 
For Each Cel In Plage
    'On remet les totaux à zéro
    TotalCM = 0
    'On boucle sur les colonnes de deux en deux
    For iOffset = 0 To iOffset Step 2
        Set CellOff = Cel.Offset(, iOffset)
        If (CellOff.Font.ColorIndex <> 10) And (CellOff.Value <> "") And (CellOff.Value <> 0) Then
            TotalCM = TotalCM + CDbl(CellOff.Value)
        End If
    Next
    'On verifie que l'activation du coef ne va pas faire franchir le nombre d'heure Max
    '"Tab_Base[TD" & Chr(10) & "répartis]"
    If TotalCM * 1.5 > CDbl(Feuil1.ListObjects("Tab_Base").ListColumns("CM" & Chr(10) & "répartis").DataBodyRange(1, 1).Value) Then
        'L'appliaction du céof ferait dépasser les maxis
        'On peut colorier une case
        Cel.Offset(, -9).Interior.ColorIndex = 3
        'ou afficher un message mais les messages, c'est plutôt pénible, surtout qu'il y a pas mal de ligne
        '[... voir aide msgbox]
    Else
        'Si pas de dépassement, on applique le coéf pour chaque cellule dela ligne
        'On boucle sur les colonnes de deux en deux
        For iOffset = 0 To iOffset Step 2
            Set CellOff = Cel.Offset(, iOffset)
            If (CellOff.Font.ColorIndex <> 10) And (CellOff.Value <> "") And (CellOff.Value <> 0) Then
                CellOff.Value = CellOff.Value * 1.5
                CellOff.Font.ColorIndex = 10
            End If
        Next
    End If
Next
 
End Sub

A tester avec pliusieurs lignes dans le tableau

++
Qwaz

**pryamani** · 17/06/2018, 22h59

Merci Qwaz pour ton retour rapide,

Je viens de faire des tests mais cela ne correspond pas trop à ce que je souhaite obtenir comme résultat.

En fait la colonne "TotalCM" est la référence à prendre en compte lors de ma saisie qui va commencer en CM1 et sur lequel une macro a déjà mis en place pour l'application du coefficient,
je saisie un nombre et je clique sur un bouton auquel j'ai rattaché la macro. du coup j'ai mon cm majoré de 1.5 et la couleur passe de noir en vert (vert majoration appliquée, noir majoration non appliquée)

Pour infos : Le total CM est une formule que j'ai mise et qui est la suivante : le nbre de groupe * nbre d'heure/par groupe *coeff 1.5 (car les CM et uniquement les CM ont une majoration de 1.5)

Mon idée : quand je saisie un nombre en CM1 et que j’applique le coeff, excel vérifie que je n'ai pas dépasser le TotalCM autorisé, si ce n'est pas le cas je continue ma saisie CM2 j'applique le coeff etc...

Si par exemple en CM3 je saisie un nombre, j'applique le coeff ça dépasse le Total CM, non seulement j'ai un message d'alerte et en plus ma saisie n'est pas validée car dépassement.

Le contrôle est à effectuer sur ma saisie (ceux les enseignants qui vont me communiquer leur heure par CM et/ou TD et à partir de ces infos je commence ma saisie si dépassement le dois les alerter car il m'est impossible de passer outre le Max autorisé)

Je ne sais pas si je me suis bien exprimée, mais n’hésite pas à me le dire

Merci beaucoup
Prya

**Qwazerty** · 18/06/2018, 12h35

Salut

OK, je n'avais pas saisi, je pense avoir mieux cerné.

Une chose que j'ai oublié dans le message précédent, si tu cliques sur le tableau "Tab_Base" et que tu vas dans le menu ruban réservé aux tableaux, sur la droite tu as des options de ligne/colonne fixes et également ligne de totaux, ça ajoute une ligne en fin de tableau avec les totaux, tu as juste à sélectionner ce que tu souhaites dans la case à l'aide d'une liste déroulante et si le calcul que tu souhaites n'y est pas, tu peux mettre une formule de ton choix.

Pour une meilleur lisibilité, tu peux utiliser la fonction figer les volets (ruban Affichage), ça te permet de figer des colonnes et des lignes.

Attention aux noms de colonne, laisser trainer des espaces et des retours à la ligne lorsqu'ils ne sont pas nécessaires complique le code VBA si tu utilises du code faisant référence aux tableaux structurés.

Code :

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

Feuil1.Range("Tab_Base[[CM répartis]]")

deviendrait avec un retour à la ligne entre les deux mots

Code :

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

Feuil1.Range("Tab_Base[[CM" & chr(10) & "répartis]]")

Inutile de se compliquer inutilement

Pour ta formule en L7, tu peux la modifier ainsi... (il existe peut-être plus simple mais je n'ai pas trouvé)

Code :

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

=SOMMEPROD(DECALER(Tab_Base[[#Cette ligne];[TD]];;1;;COLONNES(Tab_Base)-INDEX(COLONNE([TD]);1;1))*EST.IMPAIR(COLONNE(DECALER(Tab_Base[[#Cette ligne];[TD]];;1;;COLONNES(Tab_Base)-COLONNE([TD])))))

Ou si tu veux gérer le cas d'un tableau "neuf" sans CMx de renseigné

Code :

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

=SIERREUR(SOMMEPROD(DECALER(Tab_Base[[#Cette ligne];[TD]];;1;;COLONNES(Tab_Base)-INDEX(COLONNE([TD]);1;1))*EST.IMPAIR(COLONNE(DECALER(Tab_Base[[#Cette ligne];[TD]];;1;;COLONNES(Tab_Base)-COLONNE([TD])))));"")

J'ai mis les deux dans le fichier, à toi de voir et d'appliquer si tu le souhaites l'une d'elle sur l'ensemble de la colonne.
Je n'ai pas regardé les autres formules mais si besoin elle peuvent être modifiées de la même façon, l'avantage étant que tu n'auras pas besoin de réécrire tes formule à chaque agrandissement du tableau... ça évitera bien des risques d'oubli

Pour info, plutôt que d'utiliser Mod(...;2)=1, tu as Est.Impair(...) [ou son frère Est.Pair()] qui fait le boulot

Code :

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

=SOMMEPROD(EST.IMPAIR(COLONNE(U8:CT8))*(U8:CT8))

Pour ce qui est du code, plutôt que d'avoir à cliquer sur un bouton pour appliquer le coef à chaque fois, on peut utiliser l'événement Change de la feuille qui est appelé à chaque modification de contenu d'une cellule.
Ici on pourra regarder si la cellule modifiée est celle d'une colonne CMx ou TDx... et agir en fonction

Voila un exemple de code, il ne gère que CMx, il y a l'ébauche de code pour gérer TDx

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
Private Sub Worksheet_Change(ByVal Target As Range)
Const CoefCM As Double = 1.5
Const ColorCoefSet As Byte = 10
Dim iOffset As Integer
 
Dim iMaxCol As Integer, icol As Integer
Dim iCM As Integer
Dim Plage As Range, Cel As Range, CellOff As Range
Dim CellInTabBase As Range, CellInCMx As Range, CellCMx As Range
Dim iColQuotat As Integer, icolCMRepart As Integer
Dim TotalCM As Double
 
    'On vérifie qu'au moins une cellule modifiées se trouve bien dans le tableau
    Set CellInTabBase = Intersect(Target, Feuil1.Range("Tab_Base"))
    If Not CellInTabBase Is Nothing Then
        'Une pertie des cellules modifiées se trouve dans le tableau Tab_Base
 
        'On pointe les cellule de la colonne Td
        Set Plage = Feuil1.Range("Tab_Base[TD]").Offset(, 1)
        'On vérifie que CM1 existe
        If Plage.Offset(-1).Resize(1, 1).Value = "CM1" Then
            'On pointe la colonne contenant les totaux CM
            iColQuotat = Feuil1.Range("Tab_Base[[TOTAL HCM converties en HTD (coeff : 1,5)]]").Column
            'Idem CM répartis
            icolCMRepart = Feuil1.Range("Tab_Base[[CM répartis]]").Column
 
            'On recherche le nombre de colonne CM à tester
            iMaxCol = Feuil1.ListObjects("Tab_Base").ListColumns.Count - (Plage.Column - 1)
 
            'On boucle sur les colonnes CM
            For iCM = 1 To Int(iMaxCol / 2)
                'On regarde si les celules modifiées du tableau correspondent à une colonne CM
                Set CellInCMx = Intersect(CellInTabBase, Feuil1.Range("Tab_Base[CM" & CStr(iCM) & "]"))
                If Not CellInCMx Is Nothing Then
                    'Au moins une cellule d'une colonne CM a était modifiée
                    'On boucle sur ces cellules
                    For Each CellCMx In CellInCMx
                        'On vérifie le non dépassement du quotat de cette ligne si on ajoute la majoration aux CM déjà Répartis
                        If Feuil1.Cells(CellCMx.Row, iColQuotat).Value < (CellCMx.Value * (CoefCM - 1) + Feuil1.Cells(CellCMx.Row, icolCMRepart).Value) Then
                            'Dépassement du quotat d'heure
                            '...Action
                            CellCMx.Interior.ColorIndex = 3
                        Else
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellCMx.Interior.ColorIndex = xlNone
                            'On applique le coef (sans déclencher Change)
                            Application.EnableEvents = False
                            CellCMx.Value = CellCMx.Value * CoefCM
                            Application.EnableEvents = True
                        End If
                    Next
                End If
                'Idem Pour TD
                'Set CellInTDx =...
                'If Not CellinTDx is Nothing
                    'For each CellTDx in ...
                        'If Feuil1.Cells(cellTDx,icolQuotat)<Feuil1.Cells(cellTDx,icolRepart) then
                            '...
                        'End if
                    'Next
                'End If
 
            Next
        End If
    End If
End Sub

Du coup ici, plus besoin de la coloration en vert puisque le coéf est appliqué dès la modification d'une cellule.
Tu peux sélectionner plusieurs cellules pour faire une modification de valeur en masse (tu fais ta sélection avec Ctrl ou Shift puis tu tapes la valeurs que tu veux saisir dans les cellules sélectionnées puis tu valides par Ctrl+Enter)

Pour éviter les problèmes de nom de colonne et autre, tu trouveras un fichier modifié en PJ avec les propositions de modifications précédentes.

++
Qwaz

**Qwazerty** · 18/06/2018, 23h26

Envoyé par pryamani

...

En ce qui concerne l’application du code pour les TD, le soucis est qu'il n'indique pas la couleur lors du dépassement, en revanche la couleur est bien indiquée dans le "résultatTD".
Pour les CM la couleur se déclenche alors que je n'ai pas encore atteint mon quotas. la couleur se déclenche aussi quand j'ai utilisé le quotas autorise c-à-d sans aller au delà et sans être en dessous
... Que signifie STP & "]"

ça devrait se résoudre en modifiant le code comme ça

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
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
Const CoefCM As Double = 1.5
Const ColorCoefSet As Byte = 10
Dim iOffset As Integer
 
Dim iMaxCol As Integer, icol As Integer
Dim iCM As Integer
Dim Plage As Range, Cel As Range, CellOff As Range
Dim CellInTabBase As Range, CellInCMx As Range, CellCMx As Range
Dim iColQuotaCM As Integer, icolCMRepart As Integer
Dim iColQuotaTD As Integer, icolTDRepart As Integer
Dim CellInTDx As Range, CellTDx As Range
Dim TotalCM As Double
 
    'On vérifie qu'au moins une cellule modifiées se trouve bien dans le tableau
    Set CellInTabBase = Intersect(Target, Feuil1.Range("Tab_Base"))
    If Not CellInTabBase Is Nothing Then
        'Une pertie des cellules modifiées se trouve dans le tableau Tab_Base
 
        'On pointe les cellule de la colonne Td
        Set Plage = Feuil1.Range("Tab_Base[TD]").Offset(, 1)
 
        'On vérifie que CM1 existe
        If Plage.Offset(-1).Resize(1, 1).Value = "CM1" Then
            'On pointe la colonne contenant les totaux CM et TD
            iColQuotaCM = Feuil1.Range("Tab_Base[TOTAL HCM converties en HTD (coeff : 1,5)]").Column
            iColQuotaTD = Feuil1.Range("Tab_Base[TOTAL HTD]").Column
            'Idem CM et TD répartis
            icolCMRepart = Feuil1.Range("Tab_Base[CM répartis]").Column
            icolTDRepart = Feuil1.Range("Tab_Base[TD répartis]").Column
            'On recherche le nombre de colonne CM à tester
            iMaxCol = Feuil1.ListObjects("Tab_Base").ListColumns.Count - (Plage.Column - 1)
 
            'On boucle sur les colonnes CM
            For iCM = 1 To Int(iMaxCol / 2)
                'On regarde si les celules modifiées du tableau correspondent à une colonne CM
                Set CellInCMx = Intersect(CellInTabBase, Feuil1.Range("Tab_Base[CM" & CStr(iCM) & "]"))
                If Not CellInCMx Is Nothing Then
                    'Au moins une cellule d'une colonne CM a était modifiée
                    'On boucle sur ces cellules
                    For Each CellCMx In CellInCMx
                        'On vérifie le non dépassement du quotat de cette ligne si on ajoute la majoration aux CM déjà Répartis
                        If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < (CellCMx.Value * (CoefCM - 1) + Feuil1.Cells(CellCMx.Row, icolCMRepart).Value) Then
                            'Dépassement du quotat d'heure
                            '...Action
                            CellCMx.Interior.ColorIndex = 3
                        Else
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellCMx.Interior.ColorIndex = xlNone
                            'On applique le coef (sans déclencher Change)
                            Application.EnableEvents = False
                            CellCMx.Value = CellCMx.Value * CoefCM
                            Application.EnableEvents = True
                        End If
                    Next
                End If
 
                'Idem Pour TD
                'ITD n'existe pas, ici on utilise iCM puisque CM et TD on le même indice
                Set CellInTDx = Intersect(CellInTabBase, Feuil1.Range("Tab_Base[TD" & CStr(iCM) & "]"))
 
                If Not CellInTDx Is Nothing Then
 
                    'Au moins une cellule d'une colonne TD a était modifiée
                    'On boucle sur ces cellules
                    For Each CellTDx In CellInTDx
 
                        'On vérifie le non dépassement du quotat de cette ligne
                        'If Feuil1.Cells(cellTDx,iColQuotaCM)<Feuil1.Cells(cellTDx,icolRepart) then
                        'Ici il faut aller chercher la valeur du quotat
                        'If Feuil1.Cells(CellTDx.Row, iColQuotaCM).Value < (CellTDx.Value) Then
                        If Feuil1.Cells(CellTDx.Row, iColQuotaTD).Value < Feuil1.Cells(CellTDx.Row, icolTDRepart) Then
                            'Dépassement du quotat d'heure
                            CellTDx.Interior.ColorIndex = 3
                        Else
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellTDx.Interior.ColorIndex = xlNone
                            'On empêche VB de générer un évement Change qui ferait de nouveau appel à cette procédure... boucle infinie
                            Application.EnableEvents = False
                            CellTDx.Value = CellTDx.Value
                            Application.EnableEvents = True
                        End If
                    Next
                End If
            Next
        End If
    End If
End Sub

Oui c'était volontaire mais on peut modifier, le code calcul la majoration d'heure lié au quota. Si la valeur majorée fait basculer le total CM au delà du Max, la majoration ne se fait pas et la cellule passe en rouge. C'est modifiable si ça te pose problème
Si on veut faire référence à la plage de cellule de la colonne d'un tableau, on note
Code : Sélectionner tout - Visualiser dans une fenêtre à part
```
Feuil1.Range("Tab_Base[TD1]")
```
Ici on fait référence à la colonne TD1.
Maintenant si on veut pouvoir pointer les autre TD, il faut rendre la partie numérique variable, on remplace donc le 1 (de TD1) par CStr(iTD) le reste est conservé tel quel c'est à dire "Tab_Base[TD" et "]" ("Tab_Base[TD1])(
Code : Sélectionner tout - Visualiser dans une fenêtre à part
```
Feuil1.Range("Tab_Base[TD" & CStr(iTD) & "]")
```

Normalement tout fonctionne
++
Qwaz

**pryamani** · 19/06/2018, 19h55

Bonjour Qwaz,

C'est parfait ! j'ai fait plusieurs tests et cela fonctionne bien. 1000x mercis.

Quelle serait STP la modification a apporter pour que la donne ci-dessous soit prise en compte, j'avoue que c'est un peu perturbant car j'en déduis que dès que la couleur rouge apparaît c'est obligatoirement dû à un dépassement.

Oui c'était volontaire mais on peut modifier, le code calcul la majoration d'heure lié au quota. Si la valeur majorée fait basculer le total CM au delà du Max, la majoration ne se fait pas et la cellule passe en rouge. C'est modifiable si ça te pose problème où peut être la majoration ne se fait pas et rejette tout simplement la saisie. Je ne vois pas quelle est la solution la mieux adaptée. Peut être que c'est la tienne

Merci
Prya

**Qwazerty** · 19/06/2018, 22h37

Salut

En modifiant comme suit ça doit fonctionné (je n'ai pas testé)

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
                    For Each CellCMx In CellInCMx
                        'On majore l'horaire
                        'On applique le coef (sans déclencher Change)
                        Application.EnableEvents = False
                        CellCMx.Value = CellCMx.Value * CoefCM
                        Application.EnableEvents = True
 
                        'On teste si le quota est dépassé
                        If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < Feuil1.Cells(CellCMx.Row, icolCMRepart).Value Then
                            'Dépassement
                            CellCMx.Interior.ColorIndex = 3
                        Else
                            'Pas de dépassement
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellCMx.Interior.ColorIndex = xlNone
                        End If
 
'                        'On vérifie le non dépassement du quotat de cette ligne si on ajoute la majoration aux CM déjà Répartis
'                        If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < (CellCMx.Value * (CoefCM - 1) + Feuil1.Cells(CellCMx.Row, icolCMRepart).Value) Then
'                            'Dépassement du quotat d'heure
'                            '...Action
'                            CellCMx.Interior.ColorIndex = 3
'                        Else
'                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
'                            CellCMx.Interior.ColorIndex = xlNone
'                            'On applique le coef (sans déclencher Change)
'                            Application.EnableEvents = False
'                            CellCMx.Value = CellCMx.Value * CoefCM
'                            Application.EnableEvents = True
'                        End If
                    Next

++
Qwaz

**pryamani** · 20/06/2018, 21h10

Bonjour Qwaz,

j'ai testé le code et il y a un petit souci, j'ai aussi appliqué ce code pour les TD

Je t'envoie une capture d'écran c'est plus parlantPièce jointe 390094

merci

**Qwazerty** · 20/06/2018, 21h24

Salut

Le code complet, je n'ai pas pensé il y a les déclarations

[Edit]
Ben non, logiquement ça devrait fonctionner en fait

Peux-tu me donner le message d'erreur, sans lui je suis aveugle.
[/Edit]

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
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
Const CoefCM As Double = 1.5
Const ColorCoefSet As Byte = 10
Dim iOffset As Integer
 
Dim iMaxCol As Integer, icol As Integer
Dim iCM As Integer
Dim Plage As Range, Cel As Range, CellOff As Range
Dim CellInTabBase As Range, CellInCMx As Range, CellCMx As Range
Dim iColQuotaCM As Integer, icolCMRepart As Integer
Dim iColQuotaTD As Integer, icolTDRepart As Integer
Dim CellInTDx As Range, CellTDx As Range
Dim TotalCM As Double
 
    'On vérifie qu'au moins une cellule modifiées se trouve bien dans le tableau
    Set CellInTabBase = Intersect(Target, Feuil1.Range("Tab_Base"))
    If Not CellInTabBase Is Nothing Then
        'Une pertie des cellules modifiées se trouve dans le tableau Tab_Base
 
        'On pointe les cellule de la colonne Td
        Set Plage = Feuil1.Range("Tab_Base[TD]").Offset(, 1)
 
        'On vérifie que CM1 existe
        If Plage.Offset(-1).Resize(1, 1).Value = "CM1" Then
            'On pointe la colonne contenant les totaux CM et TD
            iColQuotaCM = Feuil1.Range("Tab_Base[TOTAL HCM converties en HTD (coeff : 1,5)]").Column
            iColQuotaTD = Feuil1.Range("Tab_Base[TOTAL HTD]").Column
            'Idem CM et TD répartis
            icolCMRepart = Feuil1.Range("Tab_Base[CM répartis]").Column
            icolTDRepart = Feuil1.Range("Tab_Base[TD répartis]").Column
            'On recherche le nombre de colonne CM à tester
            iMaxCol = Feuil1.ListObjects("Tab_Base").ListColumns.Count - (Plage.Column - 1)
 
            'On boucle sur les colonnes CM
            For iCM = 1 To Int(iMaxCol / 2)
                'On regarde si les celules modifiées du tableau correspondent à une colonne CM
                Set CellInCMx = Intersect(CellInTabBase, Feuil1.Range("Tab_Base[CM" & CStr(iCM) & "]"))
                If Not CellInCMx Is Nothing Then
                    'Au moins une cellule d'une colonne CM a était modifiée
                    'On boucle sur ces cellules
                    For Each CellCMx In CellInCMx
                        'On majore l'horaire
                        'On applique le coef (sans déclencher Change)
                        Application.EnableEvents = False
                        CellCMx.Value = CellCMx.Value * CoefCM
                        Application.EnableEvents = True
 
                        'On teste si le quota est dépassé
                        If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < Feuil1.Cells(CellCMx.Row, icolCMRepart).Value Then
                            'Dépassement
                            CellCMx.Interior.ColorIndex = 3
                        Else
                            'Pas de dépassement
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellCMx.Interior.ColorIndex = xlNone
                        End If
 
'                        'On vérifie le non dépassement du quotat de cette ligne si on ajoute la majoration aux CM déjà Répartis
'                        If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < (CellCMx.Value * (CoefCM - 1) + Feuil1.Cells(CellCMx.Row, icolCMRepart).Value) Then
'                            'Dépassement du quotat d'heure
'                            '...Action
'                            CellCMx.Interior.ColorIndex = 3
'                        Else
'                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
'                            CellCMx.Interior.ColorIndex = xlNone
'                            'On applique le coef (sans déclencher Change)
'                            Application.EnableEvents = False
'                            CellCMx.Value = CellCMx.Value * CoefCM
'                            Application.EnableEvents = True
'                        End If
                    Next
                End If
 
                'Idem Pour TD
                'ITD n'existe pas, ici on utilise iCM puisque CM et TD on le même indice
                Set CellInTDx = Intersect(CellInTabBase, Feuil1.Range("Tab_Base[TD" & CStr(iCM) & "]"))
 
                If Not CellInTDx Is Nothing Then
 
                    'Au moins une cellule d'une colonne TD a était modifiée
                    'On boucle sur ces cellules
                    For Each CellTDx In CellInTDx
 
                        'On vérifie le non dépassement du quotat de cette ligne
                        'If Feuil1.Cells(cellTDx,iColQuotaCM)<Feuil1.Cells(cellTDx,icolRepart) then
                        'Ici il faut aller chercher la valeur du quotat
                        'If Feuil1.Cells(CellTDx.Row, iColQuotaCM).Value < (CellTDx.Value) Then
                        If Feuil1.Cells(CellTDx.Row, iColQuotaTD).Value < Feuil1.Cells(CellTDx.Row, icolTDRepart) Then
                            'Dépassement du quotat d'heure
                            CellTDx.Interior.ColorIndex = 3
                        Else
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellTDx.Interior.ColorIndex = xlNone
                            'On empêche VB de générer un évement Change qui ferait de nouveau appel à cette procédure... boucle infinie
                            Application.EnableEvents = False
                            CellTDx.Value = CellTDx.Value
                            Application.EnableEvents = True
                        End If
                    Next
                End If
            Next
        End If
    End If
End Sub

++
Qwaz

**pryamani** · 20/06/2018, 22h29

Je viens de refaire 2 fois ce code et toujours pas et pourtant la variable y est

Pièce jointe 390113

**Qwazerty** · 20/06/2018, 22h42

Peux-tu me faire suivre un fichier ou au moins le code qui plante?

**pryamani** · 20/06/2018, 22h48

voici le code que j'ai modifié suite à tes instructions

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
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
Const CoefCM As Double = 1.5
Const ColorCoefSet As Byte = 10
Dim iOffset As Integer
 
Dim iMaxCol As Integer, icol As Integer
Dim iCM As Integer
Dim Plage As Range, Cel As Range, CellOff As Range
Dim CellInTabBase As Range, CellInCMx As Range, CellCMx As Range
Dim iColQuotaCM As Integer, icolCMRepart As Integer
Dim iColQuotaTD As Integer, icolTDRepart As Integer
Dim CellInTDx As Range, CellTDx As Range
Dim TotalCM As Double
 
    'On vérifie qu'au moins une cellule modifiées se trouve bien dans le tableau
    Set CellInTabBase = Intersect(Target, Feuil1.Range("Tab_Base"))
    If Not CellInTabBase Is Nothing Then
        'Une partie des cellules modifiées se trouve dans le tableau Tab_Base
 
        'On pointe les cellule de la colonne Td
        Set Plage = Feuil1.Range("Tab_Base[TD]").Offset(, 1)
 
        'On vérifie que CM1 existe
        If Plage.Offset(-1).Resize(1, 1).Value = "CM1" Then
            'On pointe la colonne contenant les totaux CM et TD
            iColQuotaCM = Feuil1.Range("Tab_Base[TOTAL HCM converties en HTD (coeff : 1,5)]").Column
            iColQuotaTD = Feuil1.Range("Tab_Base[TOTAL HTD]").Column
            'Idem CM et TD répartis
            icolCMRepart = Feuil1.Range("Tab_Base[CMrépartis]").Column
            icolTDRepart = Feuil1.Range("Tab_Base[TDrépartis]").Column
            'On recherche le nombre de colonne CM à tester
            iMaxCol = Feuil1.ListObjects("Tab_Base").ListColumns.Count - (Plage.Column - 1)
 
            'On boucle sur les colonnes CM
                     For Each CellCMx In CellInCMx
                        'On majore l'horaire
                        'On applique le coef (sans déclencher Change)
                        Application.EnableEvents = False
                        CellCMx.Value = CellCMx.Value * CoefCM
                        Application.EnableEvents = True
 
                        'On teste si le quota est dépassé
                        If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < Feuil1.Cells(CellCMx.Row, icolCMRepart).Value Then
                            'Dépassement
                            CellCMx.Interior.ColorIndex = 3
                        Else
                            'Pas de dépassement
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellCMx.Interior.ColorIndex = xlNone
                        End If
 
'                        'On vérifie le non dépassement du quotat de cette ligne si on ajoute la majoration aux CM déjà Répartis
                         If Feuil1.Cells(CellCMx.Row, iColQuotaCM).Value < (CellCMx.Value * (CoefCM - 1) + Feuil1.Cells(CellCMx.Row, icolCMRepart).Value) Then
'                            'Dépassement du quotat d'heure
'                            '...Action
                              CellCMx.Interior.ColorIndex = 3
                         Else
'                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellCMx.Interior.ColorIndex = xlNone
'                            'On applique le coef (sans déclencher Change)
                             Application.EnableEvents = False
                             CellCMx.Value = CellCMx.Value * CoefCM
                             Application.EnableEvents = True
                         End If
                    Next
 
 
 
          End If
 
                'Idem Pour TD
              For Each CellTDx In CellInTDx
 
                        'On teste si le quota est dépassé
                        If Feuil1.Cells(CellTDx.Row, iColQuotaTD).Value < Feuil1.Cells(CellTDx.Row, icolTDRepart).Value Then
                            'Dépassement
                            CellTDx.Interior.ColorIndex = 3
                        Else
                            'Pas de dépassement
                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellTDx.Interior.ColorIndex = xlNone
                        End If
 
'                        'On vérifie le non dépassement du quotat de cette ligne aux TD déjà Répartis
                         If Feuil1.Cells(CellTDx.Row, iColQuotaTD).Value < (CellTDx.Value * (CoefCM - 1) + Feuil1.Cells(CellTDx.Row, icolTDRepart).Value) Then
'                            'Dépassement du quotat d'heure
'                            '...Action
                              CellTDx.Interior.ColorIndex = 3
                         Else
'                            'On retire un éventuel fond rouge (en cas d'erreur de saisie, évite d'avoir à modifier manuellement la couleur de fond)
                            CellTDx.Interior.ColorIndex = xlNone
'
                         End If
              Next
 
 
 
   End If
End Sub

**Qwazerty** · 20/06/2018, 23h03

Normal, l'instanciation de CellInMCx a été retirée, quand le code exécute la ligne en défaut CellInMCx vaut Nothing
Il manque cette partie du code

Code :

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

1
2
3
4
            'On boucle sur les colonnes CM
            For iCM = 1 To Int(iMaxCol / 2)
                'On regarde si les celules modifiées du tableau correspondent à une colonne CM
                Set CellInCMx = Intersect(CellInTabBase, Feuil1.Range("Tab_Base[CM" & CStr(iCM) & "]"))

Notamment la dernière ligne.
L'utilité de cette boucle et de prendre en compte une modification multiple si tu la retires il faut faire en sorte de prendre en compte un seule des cellules modifiées sinon le code va planter.
Tu veux limiter le code avec la possibilité de modifier qu'une seule cellule à la fois? Je n'y vois pas trop d'intérêt ça réduira un peu le code mais ça ne changera rien à la vitesse d'exécution du code.

PS: Pense à utiliser les balise code pour conserver les indentation du code.

**pryamani** · 22/06/2018, 19h34

Bonjour Qwatz.

Merci beaucoup, j'avais pas saisi. Je ne sais pas utiliser les balises de code. Les tutos parlent de HTML est-cela ? je n'arrive pas à faire comme toi.

Que ce soit pour les codes ou reprendre l’essentiel du message pour y répondre d'où je passe à chaque fois par des PJ.

Je vais essayer de trouver la solution et de respecter les règles du forums.

Merci encore pour tout.

**Qwazerty** · 22/06/2018, 19h40

Salut

Il y a tout ce qu'il te faut ici.

++
Qwaz

**Biggy95** · 04/07/2018, 09h28

Bonjour la team.

J'ai un souci qui se rapproche un peu de celui exposé ici. En effet je recherche une macro qui me permette de copier les celulles d'une colonne et les coller dans une autre colonne. Chaque cellule copiée est collée deux fois et la deuxième ligne collée est affectée d'un coefficient qui est le même pour toute la colonne. Je vous joins une image explicite avec un exemple de coefficient fixé à 1,5 ici.
Dans l'attente de votre aide.

Merci. Bonne journée

Copie de colonne sous condition et application d'un coefficient [XL-2016]

Macros et VBA Excel

Discussions similaires

Partager

Partager