XL 2019 VBA / compter sur une ligne le nombre de cellules non vides de colonnes discontinues

clairedost

XLDnaute Nouveau
Bonjour et bonne année !

J'ai cherché sur plusieurs forums, et n'ai pas réussi à cherché ce que je cherchais, donc j'espère trouvé une réponse ici.

Très jeune débutante en VBA, j'aurais aimé savoir s'il est possible de compter sur une ligne le nombre de cellules non-vides de plusieurs colonnes discontinues, à chaque fois que l'on renseigne des données dans l'une d'elles.

Pour plus de clarté, je joins un fichier qui explique ma requête.

Je vous remercie d'avance de votre bienveillance à tous!
 

Pièces jointes

  • claire-compte-cellules.xlsx
    10.7 KB · Affichages: 13
Solution
Sinon en VBA avec une événementielle :
VB:
Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B2:M10000")) Is Nothing Then
        L = Target.Row: s = 0
        If Cells(L, "B") <> "" Then s = s + 1
        If Cells(L, "E") <> "" Then s = s + 1
        If Cells(L, "J") <> "" Then s = s + 1
        If Cells(L, "M") <> "" Then s = s + 1
        Cells(L, "A") = s
    End If
End Sub
La mise à jour s'effectue dès qu'on change une valeur dans les colonnes B à M.

sylvanu

XLDnaute Barbatruc
Supporter XLD
Sinon en VBA avec une événementielle :
VB:
Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B2:M10000")) Is Nothing Then
        L = Target.Row: s = 0
        If Cells(L, "B") <> "" Then s = s + 1
        If Cells(L, "E") <> "" Then s = s + 1
        If Cells(L, "J") <> "" Then s = s + 1
        If Cells(L, "M") <> "" Then s = s + 1
        Cells(L, "A") = s
    End If
End Sub
La mise à jour s'effectue dès qu'on change une valeur dans les colonnes B à M.
 

Pièces jointes

  • claire-compte-cellules.xlsm
    15.9 KB · Affichages: 8

clairedost

XLDnaute Nouveau
bonjour,
comme je l'expliquais dans la pj, les formules alourdissent mon fichier (plus de 1000 lignes, et une cinquantaine de colonnes) qui est déjà bien lourd, et cela évite aussi que l'on supprime par inadvertance les formules, car la feuille n'est pas protégée.
 

Etoto

XLDnaute Barbatruc
bonjour,
comme je l'expliquais dans la pj, les formules alourdissent mon fichier (plus de 1000 lignes, et une cinquantaine de colonnes) qui est déjà bien lourd, et cela évite aussi que l'on supprime par inadvertance les formules, car la feuille n'est pas protégée.
Hello,

Juste pour info, le VBA peut aussi ralentir et si tu te loupes, tu ne peux pas revenir en arrière avec le VB, avec les formules, tu peux quand même :) .
 

clairedost

XLDnaute Nouveau
Etoto, je suis consciente de tout ça, mais je me répète ce fichier est déjà lourd, et sera manipulé par plusieurs personnes. Donc j'aimerais automatiser le maximum de choses.

En tous cas sylvanu, un grand merci à vous, j'ai adapté votre code à mon fichier, et tout fonctionne à merveille.

Cela a l'air tellement limpide pour vous, ça m'impressionne. Peut-être devrais-je prendre des cours!

Encore mille merci une nouvelle fois, ne changez rien, vous êtes au top!!

Bonne fin de journée !
 

clairedost

XLDnaute Nouveau
Vous avez surement remarqué le défaut de cette macro, on ne peut pas savoir si on est dans le tableau ou non. Aucun critère ne permet de le savoir.
Si vous changez une valeur hors tableau, la cellule en A sera réactualisée.
Je n'ai pas remarqué de défaut... pour moi il fonctionne à la perfection... mais vue que je n'y comprends pas grand chose en vba, vous, vous avez l'oeil qui voit tout
 

Phil69970

XLDnaute Barbatruc
Bonjour à tous

Une variante qui ne concerne que les colonnes B, E,J et M pour la mise à jour de la colonne A

VB:
Sub Worksheet_Change(ByVal Target As Range)
Dim Cptr&, i&
If Not Application.Intersect(Target, Range("B:B,E:E,J:J,M:M")) Is Nothing Then
    For i = 2 To Worksheets("Feuil1").UsedRange.Rows.Count
        If Range("B" & i) > "" Then Cptr = 1
        If Range("E" & i) > "" Then Cptr = Cptr + 1
        If Range("J" & i) > "" Then Cptr = Cptr + 1
        If Range("M" & i) > "" Then Cptr = Cptr + 1
        Range("A" & i) = Cptr
        Cptr = 0
    Next i
End If
End Sub

@Phil69970
 

clairedost

XLDnaute Nouveau
Dans ma PJ, placez vous en B20 et tapez 1. Alors A20 vaut 1.
Tout dépend de votre contexte, mais là clairement on est hors du tableau, et A20 ne devrait pas bouger.
Mais comme il n'est pas possible dans cette PJ de mesurer l'étendue du tableau, on n'a guère le choix. :)
Vue comme ça, effectivement. Mais cela n'a aucune importance, car avant que j'arrive en dehors de mon tableau, je vais avoir beaucoup de marge...
 

clairedost

XLDnaute Nouveau
Bonjour à tous

Une variante qui ne concerne que les colonnes B, E,J et M pour la mise à jour de la colonne A

VB:
Sub Worksheet_Change(ByVal Target As Range)
Dim Cptr&, i&
If Not Application.Intersect(Target, Range("B:B,E:E,J:J,M:M")) Is Nothing Then
    For i = 2 To Worksheets("Feuil1").UsedRange.Rows.Count
        If Range("B" & i) > "" Then Cptr = 1
        If Range("E" & i) > "" Then Cptr = Cptr + 1
        If Range("J" & i) > "" Then Cptr = Cptr + 1
        If Range("M" & i) > "" Then Cptr = Cptr + 1
        Range("A" & i) = Cptr
        Cptr = 0
    Next i
End If
End Sub

@Phil69970
Merci de votre retour, mais celui de sylvanu fonctionne beaucoup mieux.
En effet, je ne dis pas que le vôtre ne fonctionne pas, mais la colonne A se met à jour dans son intégralité, même si les autres sont vides...
 

fanch55

XLDnaute Barbatruc
Dans ma PJ, placez vous en B20 et tapez 1. Alors A20 vaut 1.
Tout dépend de votre contexte, mais là clairement on est hors du tableau, et A20 ne devrait pas bouger.
Mais comme il n'est pas possible dans cette PJ de mesurer l'étendue du tableau, on n'a guère le choix. :)
Salut @sylvanu
Une méthode pour évaluer l'étendue dans ce classeur :
VB:
Option Explicit
Sub Worksheet_Change(ByVal Target As Range)
Dim L As Integer
    Select Case True
        Case Target.Count > 1
        Case Intersect(Target, Range("A2:" & LC.Address)) Is Nothing
        Case Else
            Application.EnableEvents = False
            L = Target.Row
            Cells(L, "A") = WorksheetFunction.Count(Cells(L, "B"), Cells(L, "E"), Cells(L, "J"), Cells(L, "M"))
            Application.EnableEvents = True
    End Select
End Sub
Function LC() As Range
    With Application.FindFormat
        .Clear: .Borders.LineStyle = xlNone
    End With
    Set LC = Columns("M").Find(What:="", SearchFormat:=True)
    If LC Is Nothing _
    Then Set LC = UsedRange.SpecialCells(xlLastCell) _
    Else Set LC = LC.Offset(-1)
End Function
 

Discussions similaires

Statistiques des forums

Discussions
311 735
Messages
2 082 023
Membres
101 873
dernier inscrit
excellllll