Automatisation VBA Comptage cellules particulier

Bonjour à tous,

Je viens vers vous pour demander de l'aide.
J'essaye de réaliser un comptage de cellules un peu particulier. Je planche depuis plusieurs jours dessus.
Voici ci dessous mon jeu de données (un aperçu !) :

janv;	fev	mars	avril	mai	juin	juillet	aout	sept	oct	nov	dec		nb_mois
1	1	0	0	0	0	0	0	0	0	0	0		10
1	0	0	1	1	0	0	0	0	0	0	0		2
0	0	0	0	1	1	1	0	0	0	1	1		3
0	1	0	0	0	0	0	1	1	0	0	0		5
0	0	0	1	1	1	0	0	0	0	0	0		6
0	0	1	0	0	1	0	0	0	1	0	0		2

J'aimerais automatiser le remplissage de la colonne nb_mois.
Voici la règle de gestion :
on commence à lire les cellules à gauche ligne par ligne,
- Compter le nombre de 0 après la première série de 1 jusqu'à la prochaine série de 1.
Vous pouvez constater les résultats dans la colonnes nb_mois.

J'espère que je suis assez clair.

J'attends vos réponse !

Merci d'avance

Balkoo ! :)

Bonjour,

Pas évident, mais ceci devrait faire l'affaire

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25

Sub Totaux() Dim I As Long, J As Long Dim nbLignes As Long, Somme As Long Dim Debut As Boolean   nbLignes = Cells(Rows.Count, "A").End(xlUp).Row   For I = 2 To nbLignes Somme = 0 Debut = False For J = 1 To 12 If Cells(I, J) = 1 And Cells(I, J + 1) = 0 Then Debut = True ElseIf (Cells(I, J) = 0 And Cells(I, J + 1) = 1) Or J + 1 = 13 Then If Debut = True Then Somme = Somme + 1 Cells(I, 13) = Somme Exit For End If ElseIf Cells(I, J) = 0 And Debut = True Then Somme = Somme + 1 End If Next Next End Sub

---

Tout d'abord merci pour la réponse aussi rapide!

Parmi,
le code me retourne la valeur -1 a chaque fois...
De plus, faudrait-il ne pas mettre une variable "fin" de type boolean : enchainement de 0 et 1(de la même façon que "début" : enchainement de 1 et 0) ?
On compterais alors le nombre de 0 entre début et le premier fin. Mais est-ce possible de coder cela ? ..


Je voulais ajouter une précision sur l'exemple. La valeur de nb_mois de la première ligne est bien 10 !
Plus précisément la règle est :
nb_mois = nombre de 0 après la première série de 1 jusqu'à la prochaine série de 1 ou jusqu'à la dernière colonne de données si il n'y a pas de série de 1 (d'où 10 sur l'exemple).


Merci !

Balkoo

Pourtant le résultat était bon avec mon code.
J'avais mis les données telles que tu les as inscrites, en colonne A à partir de la ligne 2 et les mois sur la ligne 1

Si les données sont dans d'autres colonnes, modifie les boucles et le J + 1 = 13

Bonsoir,

il me semble que la version de Parmi fonctionne!

Je mesuis essayé sur plusieurs solution en tout cas en voici une:

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

Sub test2() Dim Der_Ligne As Integer Dim I, t, e As Integer   Der_Ligne = Sheets("feuil1").Range("A65536").End(xlUp).Row   For I = 2 To Der_Ligne For t = 1 To 11 If Cells(I, t) = 1 And Cells(I, t + 1) = 0 Then For e = t + 1 To 12 If Cells(I, e) = 1 Then Cells(I, 13) = e - t - 1   Exit For Else If Cells(I, 12) = 0 Then Cells(I, 13) = 12 - t   End If Next e Exit For Else Cells(I, 13) = 0 End If Next Next   End Sub

---

Comme dit Parmi 'Pas facile ' mais sympa pour les TORDU !:lol:

Re

avec une petite modif au cas ou on trouve que des "1" ou des "0"

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

Sub test2() Dim Der_Ligne As Integer Dim I, t, e As Integer   Der_Ligne = Sheets("feuil1").Range("A65536").End(xlUp).Row   For I = 2 To Der_Ligne For t = 1 To 11 If Cells(I, t) = 1 And Cells(I, t + 1) = 0 Then For e = t + 1 To 12 If Cells(I, e) = 1 Then Cells(I, 13) = e - t - 1   Exit For Else If Cells(I, 12) = 0 Then Cells(I, 13) = 12 - t   End If Next e Exit For Else If Cells(I, 12) = 0 Then Cells(I, 13) = 12 ' cas ou il y a que des 0 If Cells(I, 12) = 1 Then Cells(I, 13) = 0 ' cas ou il y a que des 1   End If Next Next

---

En effet, les codes fonctionnent parfaitement sur l'exemple que j'ai donné ....
Malheureusement, ils ne fonctionnent pas sur mon vrai jeu de données.

Voici quelques caractéristiques :
Il est composé de 43 colonnes et 536 lignes
Les colonnes à "scanner" sont de la 29 à la 43
La variable "nb_mois" se trouve en colonne 16

Voilà les modifications que j'ai apporté au code :

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19

For I = 2 To 536 For t = 29 To 42 If Cells(I, t) = 1 And Cells(I, t + 1) = 0 Then For e = t + 1 To 15 '42-29 = 15 If Cells(I, e) = 1 Then Cells(I, 16) = e - t - 1 Exit For Else If Cells(I, 43) = 0 Then Cells(I, 16) = 43 - t End If Next e Exit For Else If Cells(I, 43) = 0 Then Cells(I, 16) = 12 If Cells(I, 43) = 1 Then Cells(I, 16) = 0 End If Next Next

---

Au final, il me retourne que des 12 ou des valeurs manquantes : "".

J'ai dû mal a comprendre pourquoi...

Merci pour votre aide, c'est très sympa !

Balkoo

Une fonction personnalisée qui permet de compter la première série de 0 après 1. Elle prend en paramètre la plage de cellules à scruter.

Code:

---

1 2 3 4 5 6

Function Nbr(ByVal Rng As Range) As Integer Dim Tmp As String   Tmp = Join(Application.Transpose(Application.Transpose(Rng.Rows(1))), "") If InStr(Tmp, "10") Then Nbr = InStr(Mid(Tmp, InStr(Tmp, "10") + 1) & "1", "1") - 1 End Function

---

Écrite dans un module standard, on peut l'appeler directement sur la feuille, sinon au sein d'une autre procédure comme ceci

Code:

---

1 2 3 4 5 6 7 8

Sub Test()   Application.ScreenUpdating = False With Worksheets("Feuil1").Range("P2:P536") .Formula = "=Nbr(AC2:AQ2)" .Value = .Value End With End Sub

---

Bon c'est 42 ou 43?

42 ou 43 en partant de 29 ça fait 14 ou 15 mois ! Déja que je me demande à quoi ça peu bien servir alors 14 ou 15 mois dans une année? Dans quel monde vie-tu ? :ptdr:

mais bon c quand même sympa, donc la colonne de début est bien la 29 et la colonne de fin est bien la 43 si ce n'est pas le cas alors à adapter!

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

Sub modifTest() For I = 2 To 536 For t = 29 To 42 If Cells(I, t) = 1 And Cells(I, t + 1) = 0 Then For e = t + 1 To 42 If Cells(I, e) = 1 Then Cells(I, 16) = e - t - 1   Exit For Else If Cells(I, 42) = 0 Then Cells(I, 16) = 43 - t   End If Next e Exit For Else If Cells(I, 42) = 0 Then Cells(I, 16) = 14 If Cells(I, 42) = 1 Then Cells(I, 16) = 0 End If Next Next   End Sub

---

Citation:

---

Envoyé par mercatog

Une fonction personnalisée qui permet de compter la première série de 0 après 1. Elle prend en paramètre la plage de cellules à scruter.

Code:

---

1 2 3 4 5 6

Function Nbr(ByVal Rng As Range) As Integer Dim Tmp As String   Tmp = Join(Application.Transpose(Application.Transpose(Rng.Rows(1))), "") If InStr(Tmp, "10") Then Nbr = InStr(Mid(Tmp, InStr(Tmp, "10") + 1) & "1", "1") - 1 End Function

---

Écrite dans un module standard, on peut l'appeler directement sur la feuille, sinon au sein d'une autre procédure comme ceci

Code:

---

1 2 3 4 5 6 7 8

Sub Test()   Application.ScreenUpdating = False With Worksheets("Feuil1").Range("P2:P536") .Formula = "=Nbr(AC2:AQ2)" .Value = .Value End With End Sub

---

---

Vu comme ça ça parrait simple mais BRAVO
sauf lorsqu'il y a que des 1 ou que des 0 . Mais un point!:bravo:

@ Jijie

Lorsqu'il n'y a que des 0 ou des 1, le résultat obtenu est 0


Par contre, pour votre contribution, quel résultat vous donne ces contre exemples: 111111111110 ou 000000000010 ?

Citation:

---

Envoyé par mercatog

@ Jijie

Lorsqu'il n'y a que des 0 ou des 1, le résultat obtenu est 0


Par contre, pour votre contribution, quel résultat vous donne ces contre exemples: 111111111110 ou 000000000010 ?

---

Salut mercatog,

Je trouve 1 pour les deux solutions! et il me semble que c'est bien ça! Par contre tu a raison :oops: pour que des 1 ou des 0 le résultat obtenu doit bien être 0 alors ds ma version et selon le problème posé il faut :

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29

Sub test2() Dim Der_Ligne As Integer Dim I, t, e As Integer   Der_Ligne = Sheets("feuil1").Range("A65536").End(xlUp).Row   For I = 2 To Der_Ligne For t = 1 To 11 If Cells(I, t) = 1 And Cells(I, t + 1) = 0 Then For e = t + 1 To 12 If Cells(I, e) = 1 Then Cells(I, 13) = e - t - 1   Exit For Else If Cells(I, 12) = 0 Then Cells(I, 13) = 12 - t   End If Next e Exit For Else If Cells(I, 12) = 0 Then Cells(I, 13) = 0 ' cas ou il y a que des 0 If Cells(I, 12) = 1 Then Cells(I, 13) = 0 ' cas ou il y a que des 1   End If Next Next   End Sub

---

Mais ne t’inquiète pas pour ta solution qui fonctionne et que je ne comprends pas, on ne peut-être qu'admiratif ! A contrario je pense que tu comprends ma solution?

Amicalement,

Citation:

---

Envoyé par jijie

A contrario je pense que tu comprends ma solution?

Amicalement,

---

Bonjour jijie

Oui certes, mais votre proposition telle que formulée demande une amélioration ou optimisation (si tu fais le pas à pas tu remarqueras qu'elle fait des redondances de traitement non nécessaires)

Je me suis permis de l'optimiser ainsi

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24

Sub Test3() Dim t As Integer, e As Integer, N As Integer Dim Der_Ligne As Long, i As Long   Application.ScreenUpdating = False With Worksheets("Feuil1") Der_Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 2 To Der_Ligne For t = 1 To 11 If .Cells(i, t) = 1 And .Cells(i, t + 1) = 0 Then Exit For Next t   If t < 12 Then For e = t + 1 To 11 If .Cells(i, e) = 0 And .Cells(i, e + 1) = 1 Then Exit For Next e N = e - t Else N = 0 End If .Cells(i, 13) = N Next i End With End Sub

---

PS. Attention à la manière avec laquelle tu déclares tes variables.


Pour ma proposition, j'ai travaillé sur un string composé de 0 et 1 et le but était de compter les 0 entre la première séquence 10 et la séquence 01 qui suit.

J'ajoute à la fin du mot initial un 1 pour gérer les séries qui se terminent par des 0

La transformation du contenu d'une plage de cellules en une chaine de caractère nécessite un petit jonglage avec double Transpose et Join

Cette variante sera plus compréhensible et le sera plus si elle est décomposée:

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17

Function Nbr(ByVal Rng As Range) As Integer Dim Tmp As String, S As String, T As String Dim Tb   Tb = Application.Transpose(Application.Transpose(Rng.Rows(1))) 'La double transose permet de convertir un tableau (1 To N, 1 To 1) en un tableau (1 to N) 'A l'aide de Join, je transforme le tableau en chaine de caractère concaténée à partir des éléments du tableau et séparés par "" (un vide) S = Join(Tb, "") 'je concatène le mot avec un 1 à la fin pour gérer le cas où on a un 0 final S = S & "1" 'S'il existe une séquence 10 dans le mot If InStr(S, "10") Then 'je tronque le mot à partir de la 1ère séquence 10 T = Mid(S, InStr(S, "10") + 1) 'le nombre cherché est celui des 0 avant la première séquence 01 du nouveau mot T tronqué précédement Nbr = InStr(T, "01") End If End Function

---

Enfin, on peut aisément condenser le code comme ceci (ou comme celui du #8):

Code:

---

1 2 3 4 5 6

Function Nbr(ByVal Rng As Range) As Integer Dim Tmp As String   Tmp = Join(Application.Transpose(Application.Transpose(Rng.Rows(1))), "") & "1" If InStr(Tmp, "10") Then Nbr = InStr(Mid(Tmp, InStr(Tmp, "10") + 1), "01") End Function

---

Merci pour votre implication ! Et en fait, tout cela semble fonctionner à merveille !

J'avais cependant simplifier l'exemple ....

En fait, ce n'est pas forcément des 1 mais des nombres supérieures à 0 !
exemple :

12	250	28	0	0	0	0	0	0	0	0	0	106	130	35
0	0	0	0	0	0	0	0	0	20	12	0	0	0	0
...

Ça semble un peu plus compliqué...

Tu n'as pas donc pu adapter la proposition de jijie

Je te la fais

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28

Sub Test3() Dim cD As Integer, cF As Integer, cR As Integer Dim T As Integer, e As Integer, N As Integer Dim Der_Ligne As Long, i As Long   Application.ScreenUpdating = False cD = 29 'colonne de début cF = 43 'colonne de fin cR = 16 'colonne résultats With Worksheets("Feuil1") Der_Ligne = .Cells(.Rows.Count, cD).End(xlUp).Row For i = 2 To Der_Ligne For T = cD To cF - 1 If .Cells(i, T) <> 0 And .Cells(i, T + 1) = 0 Then Exit For Next T   If T < cF Then For e = T + 1 To cF - 1 If .Cells(i, e) = 0 And .Cells(i, e + 1) <> 0 Then Exit For Next e N = e - T Else N = 0 End If .Cells(i, cR) = N Next i End With End Sub

---

Super ! Merci beaucoup ! ;-) Super site, super forum !