VBA - Décompte caractères d'une même colonne

[JBond13600]

Bonjour le Forum,

Ma problématique actuelle est la comptabilisation de données contenues dans une colonne.

1/- Dans un fichiers contenant plusieurs feuilles, quelque soit leur nom, et quelque soit le contenu des autres cellules
2/- La colonne à traiter est toujours la même : La colonne "I"
3/- La colonne "I" ne comporte que 2 caractères : (*) et (0)
4/- Le truc est de comptabiliser le nombre de (*) entre chaque (0) et de reporter le nombre trouvé dans la colonne "J" dans la cellule sur la même ligne que le (0), ceci dans toutes les feuilles du fichier.
5/- Lorsque la série se termine par un ou plusieurs (*) leur somme est reportée dans la colonne "K" dans la cellule sur la même ligne que le dernier (*), ceci dans toutes les feuilles du fichier aussi.

En fichier joint le résultat attendu.

 

[phlaurent55]

Bonjour JBond,

avec ce code à mettre dans un module:

Sub Macro1()
On Error Resume Next
For feuille = 1 To Sheets.Count
With Sheets(feuille)
debut = 0
For i = 1 To .Range("I65535").End(xlUp).Row + 1
If .Cells(i, "I") = "" Then
.Cells(i - 1, "K") = i - 1 - debut
GoTo fin
End If
If .Cells(i, "I") = 0 Then
    .Cells(i, "J") = i - 1 - debut
    debut = i
End If
Next i
End With
fin:
Next feuille
End Sub

à+
Philippe

 

[jp14]

Bnjour JBond13600, phlaurent55

En reprenant une réponse d'un post précédant, ci dessous la procédure modifiée.

Option Explicit
Dim Cellule1 As Range, Plg1 As String, Dl1 As Long, Dl2 As Long, Dl3 As Long, Plg3 As Range
Dim Col1 As String

Sub Demande()
Dim Sh As Worksheet
  For Each Sh In Worksheets
  Dl3 = 1
  CompterLesEtoiles "I", Sh.Name
  Next Sh
End Sub
'---------------------------------------------------
' Module  : Module1/CompterLesEtoiles
' Utilisation  :3)- Si la première cellule contient une étoile,
'--------------------------------------------------
Private Sub CompterLesEtoiles(Col1 As String, Nomfeuille1 As String)
Dim Plg3 As Range
With Sheets(Nomfeuille1)
  Dl2 = .Range(Col1 & .Rows.Count).End(xlUp).Row
  Set Plg3 = .Range(Col1 & Dl3 & ":" & Col1 & Dl2)
  Dl1 = 0
For Each Cellule1 In Plg3
  If Cellule1 = 0 Then
  Cellule1.Offset(0, 1) = Dl1: Dl1 = 0
  Else
  '''''''''Cellule1.Offset(0, 1) = Dl1 
  Dl1 = Dl1 + 1
  End If
Next Cellule1
If .Range("I" & Dl2) = "*" Then .Range("J" & Dl2) = Dl1
End With
End Sub

JP14

 

[JBond13600]

Merci pour vos réponses Philippe et JP14,

Philippe, ta macro fonctionne comme demandé mais seulement sur la première feuille.
JP14, ta macro fonctionne sur toutes les feuilles comme demandé mais les résultats attendus en colonne "K" se trouvent en colonne "J".

On va y arriver, lol

@+++

 

[jp14]

Bonsoir

Il faut modifier le code :
Pour la fin de la série (dernière ligne)
If .Range("I" & Dl2) = "*" Then .Range("J" & Dl2) = Dl1
en remplaçant "J" par "K"
If .Range("I" & Dl2) = "*" Then .Range("K" & Dl2) = Dl1

Pour choisir une autre colonne il faut modifier la valeur de l'offset
Colonne départ I 1 colonne J, 2 colonne K, ......
If Cellule1 = 0 Then
Cellule1.Offset(0, 1) = Dl1: Dl1 = 0

Par
Cellule1.Offset(0, 2) = Dl1: Dl1 = 0

A tester
JP

 

[phlaurent55]

Merci pour vos réponses Philippe et JP14,

Philippe, ta macro fonctionne comme demandé mais seulement sur la première feuille.
JP14, ta macro fonctionne sur toutes les feuilles comme demandé mais les résultats attendus en colonne "K" se trouvent en colonne "J".

On va y arriver, lol

@+++

Bizarre je vie de refaire le test, ça fonctionne bien sur toutes les feuilles

Ä+
Philippe

 

[JBond13600]

Merci à vous,

En fait les premières lignes de ma structure étaient vides.