Problème ma macro change

Résolu
viret1290 Messages postés 146 Statut Membre -  
viret1290 Messages postés 146 Statut Membre -
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")



A voir également:

4 réponses

Réponse 1 / 4
michel_m Messages postés 18903 Statut Contributeur 3 317
 
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 +18

et 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 ?
0
Réponse 2 / 4
viret1290 Messages postés 146 Statut Membre 2
 
C'est une saisie
0
michel_m Messages postés 18903 Statut Contributeur 3 317
 
Il semble y avoir des incohérences comme

Cells(i, 70) = Cells(i, 70) + 1
puis + loin
If Cells(i, 70) <> "" Or Cells(i + 1, 70) <> ""

cells(i,70) a pour valeur mini 1 et donc le
If Cells(i, 70) <> "" Or Cells(i + 1, 70) <> ""
est toujours Vrai

????
je me trompe ou pas ?
0
Réponse 3 / 4
michel_m Messages postés 18903 Statut Contributeur 3 317
 
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 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
0
Réponse 4 / 4
viret1290 Messages postés 146 Statut Membre 2
 
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é.
0

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses
recup couleur de cellule sans macro
magouero -
JvDo -

7 réponses