Problème ma macro change Résolu/Fermé

Question

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") Configuration: Windows 7 / Firefox 42.0

michel_m · Answer

Bonjour

déjà pour éviter la trop longue liste de  if cells(2,6), restons simple
If 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 ?

viret1290 · Answer

C'est une saisie

michel_m · Answer

re,
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 BooleanDim Derlig As ByteDim Zone As Range, Cellule As RangeDim 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 IfEnd Sub

viret1290 · Answer

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é.

Problème ma macro change

4 réponses

Discussions similaires