Problème ma macro change

Résolu/Fermé

viret1290 Messages postés 137 Date d'inscription samedi 17 août 2013 Statut Membre Dernière intervention 12 octobre 2022 - 5 avril 2016 à 07:23
viret1290 Messages postés 137 Date d'inscription samedi 17 août 2013 Statut Membre Dernière intervention 12 octobre 2022 - 6 avril 2016 à 14:25

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:

Problème ma macro change
Macro word - Guide
Macro logiciel - Télécharger - Organisation
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Macro recorder - Télécharger - Confidentialité
Change dns - Guide

4 réponses

Réponse 1 / 4

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
5 avril 2016 à 08:49

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 ?

Réponse 2 / 4

viret1290 Messages postés 137 Date d'inscription samedi 17 août 2013 Statut Membre Dernière intervention 12 octobre 2022 2
5 avril 2016 à 10:58

C'est une saisie

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
5 avril 2016 à 11:43

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 ?

Réponse 3 / 4

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
5 avril 2016 à 15:10

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

Réponse 4 / 4

viret1290 Messages postés 137 Date d'inscription samedi 17 août 2013 Statut Membre Dernière intervention 12 octobre 2022 2
6 avril 2016 à 14:25

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

Discussions similaires

compte facebook piraté et adresse email changé

Compte facebook piraté, mail chngé, appareils deconnectés

Netflix change de langue tout seul

Facebook piraté, adresse e-mail et mot de passe changés

Transformer un chiffre en lettres dans excel sans macro

Discussions similaires

Newsletters