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

[clairedost]

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!

 

[sylvanu]

Bonjour Clairedost, et bienvenue sur XLD,
Pourquoi du VBA, vous y tenez ?
Car une simple formule en A2 :

=SI(ESTVIDE(B2);0;1)+SI(ESTVIDE(E2);0;1)+SI(ESTVIDE(J2);0;1)+SI(ESTVIDE(M2);0;1)

 

[sylvanu]

Sinon en VBA avec une événementielle :

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.

 

[clairedost]

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.

 

[sylvanu]

Voir PJ #3.

 

[clairedost]

Re bonjour, le temps que je réponde à votre premier message, vous aviez déjà mis à jour le code.
Je teste, et vous dis ça.

 

[Etoto]

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]

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 !

 

[sylvanu]

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.

 

[clairedost]

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

 

[sylvanu]

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.

 

[Phil69970]

Bonjour à tous

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

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]

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]

Bonjour à tous

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

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]

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 :

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