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")

4 réponses

  1.
    michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    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
  2. viret1290 Messages postés 146 Statut Membre 2
     
    C'est une saisie
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      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
  3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    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
  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

Ma TV change de chaine toute seule
isabelledes -
Lule -

40 réponses
Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses
Google est par défaut, mais change de moteur de recherche
Mathis5454000 -
pistouri -

3 réponses