Problème ma macro change
Résolu
Bonjour,
La macro ci-dessous fonctionne par bouton, mais j'aimerai la faire fonctionnée par Sub change.
Que quand je change une cellule il lance la macro
Merci d'avance
ActiveSheet.Unprotect ("BibleYo")
'N° de détenu = nombre de lignes
If Cells(6, 2) = "1" Then
a = 18
End If
If Cells(6, 2) = "2" Then
a = 21
End If
If Cells(6, 2) = "3" Then
a = 24
End If
If Cells(6, 2) = "4" Then
a = 27
End If
If Cells(6, 2) = "5" Then
a = 30
End If
If Cells(6, 2) = "6" Then
a = 33
End If
If Cells(6, 2) = "7" Then
a = 36
End If
If Cells(6, 2) = "8" Then
a = 39
End If
If Cells(6, 2) = "9" Then
a = 42
End If
If Cells(6, 2) = "10" Then
a = 45
End If
If Cells(6, 2) = "11" Then
a = 48
End If
If Cells(6, 2) = "12" Then
a = 51
End If
If Cells(6, 2) = "13" Then
a = 54
End If
If Cells(6, 2) = "14" Then
a = 57
End If
If Cells(6, 2) = "15" Then
a = 60
End If
If Cells(6, 2) = "16" Then
a = 63
End If
If Cells(6, 2) = "17" Then
a = 66
End If
If Cells(6, 2) = "18" Then
a = 69
End If
If Cells(6, 2) = "19" Then
a = 72
End If
If Cells(6, 2) = "20" Then
a = 75
End If
If Cells(6, 2) = "21" Then
a = 78
End If
If Cells(6, 2) = "22" Then
a = 81
End If
If Cells(6, 2) = "23" Then
a = 84
End If
If Cells(6, 2) = "24" Then
a = 87
End If
If Cells(6, 2) = "25" Then
a = 90
End If
If Cells(6, 2) = "26" Then
a = 93
End If
If Cells(6, 2) = "27" Then
a = 96
End If
'Efface les totaux par détenus
Columns("BR:BR").Select
Selection.ClearContents
'Efface les totaux par jours
Range(Cells(a + 2, 11), Cells(a + 2, 41)).ClearContents
Range(Cells(8, 42), Cells(a, 42)).ClearContents
For i = 8 To a
For j = 11 To 41
If Cells(i, j) = "X" Then
Cells(a + 2, j) = Cells(a + 2, j) + 1
End If
Next
Next
For i = 8 To a
For j = 11 To 41
If Cells(i, j) = "X" Then
Cells(i, 70) = Cells(i, 70) + 1
End If
Next
Next
For i = 8 To a
If Cells(i, 70) <> "" Or Cells(i + 1, 70) <> "" Then
Cells(i, 42) = Cells(i, 70) + Cells(i + 1, 70)
End If
Next
For i = 8 To a
If Cells(i, 6) <> "" Then
Cells(i + 2, 42).Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
' Cells(i + 2, 42).ClearContents
End If
Next
ActiveSheet.Protect ("BibleYo")
La macro ci-dessous fonctionne par bouton, mais j'aimerai la faire fonctionnée par Sub change.
Que quand je change une cellule il lance la macro
Merci d'avance
ActiveSheet.Unprotect ("BibleYo")
'N° de détenu = nombre de lignes
If Cells(6, 2) = "1" Then
a = 18
End If
If Cells(6, 2) = "2" Then
a = 21
End If
If Cells(6, 2) = "3" Then
a = 24
End If
If Cells(6, 2) = "4" Then
a = 27
End If
If Cells(6, 2) = "5" Then
a = 30
End If
If Cells(6, 2) = "6" Then
a = 33
End If
If Cells(6, 2) = "7" Then
a = 36
End If
If Cells(6, 2) = "8" Then
a = 39
End If
If Cells(6, 2) = "9" Then
a = 42
End If
If Cells(6, 2) = "10" Then
a = 45
End If
If Cells(6, 2) = "11" Then
a = 48
End If
If Cells(6, 2) = "12" Then
a = 51
End If
If Cells(6, 2) = "13" Then
a = 54
End If
If Cells(6, 2) = "14" Then
a = 57
End If
If Cells(6, 2) = "15" Then
a = 60
End If
If Cells(6, 2) = "16" Then
a = 63
End If
If Cells(6, 2) = "17" Then
a = 66
End If
If Cells(6, 2) = "18" Then
a = 69
End If
If Cells(6, 2) = "19" Then
a = 72
End If
If Cells(6, 2) = "20" Then
a = 75
End If
If Cells(6, 2) = "21" Then
a = 78
End If
If Cells(6, 2) = "22" Then
a = 81
End If
If Cells(6, 2) = "23" Then
a = 84
End If
If Cells(6, 2) = "24" Then
a = 87
End If
If Cells(6, 2) = "25" Then
a = 90
End If
If Cells(6, 2) = "26" Then
a = 93
End If
If Cells(6, 2) = "27" Then
a = 96
End If
'Efface les totaux par détenus
Columns("BR:BR").Select
Selection.ClearContents
'Efface les totaux par jours
Range(Cells(a + 2, 11), Cells(a + 2, 41)).ClearContents
Range(Cells(8, 42), Cells(a, 42)).ClearContents
For i = 8 To a
For j = 11 To 41
If Cells(i, j) = "X" Then
Cells(a + 2, j) = Cells(a + 2, j) + 1
End If
Next
Next
For i = 8 To a
For j = 11 To 41
If Cells(i, j) = "X" Then
Cells(i, 70) = Cells(i, 70) + 1
End If
Next
Next
For i = 8 To a
If Cells(i, 70) <> "" Or Cells(i + 1, 70) <> "" Then
Cells(i, 42) = Cells(i, 70) + Cells(i + 1, 70)
End If
Next
For i = 8 To a
If Cells(i, 6) <> "" Then
Cells(i + 2, 42).Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
' Cells(i + 2, 42).ClearContents
End If
Next
ActiveSheet.Protect ("BibleYo")
4 réponses
-
ContributeurBonjour
déjà pour éviter la trop longue liste de if cells(2,6), restons simpleIf range("F2")>0 then: a=(range("F2")-1)*3 +18et on supose que la valeur qui change est bien F2 ?
Si oui la valeur dans F2 est elle une saisie ou le résultat d'une formule dans F2 ? -
C'est une saisie
-
Contributeurre,
sans réponse et en attendant
a copier dans le module feuille concernée (par ex feuil1(feuil1)Option Explicit
'-------------
Private Sub Worksheet_Change(ByVal Target As Range)
Static Flag As Boolean
Dim Derlig As Byte
Dim Zone As Range, Cellule As Range
Dim Nbre As Integer, Cptr As Integer, Col As Byte, Lig As Byte
If Target.Address = "$B$6" And Flag = False Then
Flag = True
ActiveSheet.Unprotect
If Target > 0 Then
Application.ScreenUpdating = False
Derlig = (Target - 1) * 3 + 18
'---------nettoyage
'Efface les totaux par détenus
Columns("BR").ClearContents
'Efface les totaux par jours
Range("K20:AO98").ClearContents
Range("AP8:AP96").ClearContents
'--------------comptage
' zone de recherche
Set Zone = ActiveSheet.Range(Cells(8, "K"), Cells(Derlig, "AO"))
Nbre = Application.CountIf(Zone, "X")
'recherche des "X" dans la zone
With Zone
Set Cellule = Zone.Find(what:="X", LookIn:=xlValues)
For Cptr = 1 To Nbre
Col = Cellule.Column
Lig = Cellule.Row
'comptage jours
Cells(Derlig + 2, Col) = Cells(Derlig + 2, Col) + 1
Cells(Lig, "BR") = Cells(Lig, "BR") + 1
'comptage détenus
Cells(Lig, "AP") = Cells(Lig, "BR") + Cells(Lig + 1, "BR")
Set Cellule = .FindNext(Cellule)
Next
End With
For Lig = 8 To Derlig
If Cells(Lig, "F") <> "" Then Cells(Lig + 2, "AP").Font.ThemeColor = xlThemeColorDark1
Next
ActiveSheet.Protect
End If
Flag = False
End If
End Sub
-
Désolé, mais je n'avais pas de connexion internet.
Je ne sais pas pourquoi, mais sans rien faire ça fonctionne.
Merci énormément et désolé.
