contare la consecutivita

[raimea]

ciao
tramite macro
vorrei compilare la tabella consecutivita' in fgl squadre Col AC7:AC21

analizzando fgl generale col K8:K
contare quante volte ho avuto 1 sola consec. con segno V e poi 1na Con P
poi quante volte ho avuto 2 volte consec. V e poi 2 volte P
quante volte ho avuto 3 volte consec. V e poi 3 volte P ecc...

andando a riportare i dati ottenuti in fgl squadre
col AD7:AD21 per le vincite V consec.
e col AE7:AE21 per le perdite P consec.

vi allego il file

https://www.dropbox.com/scl/fo/5w3u7mdfgubdzhf3ze9Zc/h?dl=0&rlkey=r7g4chg7o83usbxp1b8zysw21

ciao

[Anthony47]

Il link allegato non funziona...

[raimea]

scusate...
ho sbagliato a mettere il link !!

ecco il link corretto
riferito al 1mo post:

https://www.dropbox.com/scl/fi/i6khp1gk879lv44aub01a/consecutivita.xlsm?dl=0&rlkey=l7azkhx11b80fhzg2mtc4evf5

ciao

[Anthony47]

A me questa sembra funzionare:

Codice: Seleziona tutto

Sub Consec()
Dim strVP As String, I As Long, J As Long, Ck As String
Dim lDiff As Long, oArr(1 To 15, 1 To 2)
'
strVP = Application.WorksheetFunction.TextJoin("", True, Sheets("generale").Range("K8:K10000"))
For I = 15 To 1 Step -1
    For J = 1 To 2
        If J = 1 Then Ck = "V" Else Ck = "P"
        lDiff = Len(strVP) - Len(Replace(strVP, String(I, Ck), "", , , vbTextCompare))
        If lDiff > 0 Then
            oArr(I, J) = lDiff / I
            strVP = Replace(strVP, String(I, Ck), "###", , , vbTextCompare)
        End If
    Next J
Next I
Sheets("Squadre").Range("AD7").Resize(15, 2).Value = oArr
End Sub

..e i risultati mi sembrano pure giusti

[raimea]

ciao
e' tutto ok

grazie

[raimea]

ciao
la macro Consec in modulo 5
pare non faccia i conteggi corretti delle consecutivita'
in fgl tabelle col AD

l' ultima sequenza di Vinti V in fgl generale e' di 17 consecutivi
ma la macro non lo riporta

vi allego il file

https://www.dropbox.com/scl/fi/hgg2nltxjz50k7v0n66oi/Consecutivita_V_P.xlsm?rlkey=7v4kf4a2bg617akcbabcilxjz&dl=0

ciao

[Anthony47]

La macro precedente calcolava fino a 15, perche' così era impostato il file di esempio che pubblicasti.

Per poter gestire il limite come impostato in foglio Tabelle colonna AC ho fatto un paio di modifiche qua e là; il nuovo codice complessivo:

Codice: Seleziona tutto

Sub ConsecFlex()
Dim strVP As String, i As Long, J As Long, Ck As String
Dim lDiff As Long, oArr()
'------------------
' serve compilare tabella consecutivita fgl Tabelle
' pc - facile   gennaio 23
'  http://www.pc-facile.com/forum/viewtopic.php?f=26&t=112784&p=663028#p663028
'----------------------
Worksheets("Tabelle").Unprotect   ' togli protez
maxx = Application.WorksheetFunction.Max(Sheets("Tabelle").Range("AC:AC"))
ReDim oArr(1 To maxx, 1 To 2)
strVP = Application.WorksheetFunction.TextJoin("", True, Sheets("generale").Range("K8:K10000"))
For i = maxx To 1 Step -1
    For J = 1 To 2
        If J = 1 Then Ck = "V" Else Ck = "P"
        lDiff = Len(strVP) - Len(Replace(strVP, String(i, Ck), "", , , vbTextCompare))
        If lDiff > 0 Then
            oArr(i, J) = lDiff / i
            strVP = Replace(strVP, String(i, Ck), "###", , , vbTextCompare)
        End If
    Next J
Next i
Sheets("Tabelle").Range("AD7").Resize(maxx, 2).Value = oArr

  '-------coloro riga si no --------------------------------
   
      For Z = 7 To Cells(Rows.Count, "AC").End(xlUp).Row  ' 7 1ma riga
   
    Range("AC7:AE1000").Interior.ColorIndex = 2  '<<< sfondo bianco
    Range("AC7:AE1000").Font.Bold = False
    Next Z
   
    For RR = 7 To Z Step 2
       Range("AC" & RR & ":AE" & RR).Interior.ColorIndex = 8 ' azzurro chiaro
       Range("AC" & RR & ":AE" & RR).Font.Bold = True
    Next RR

' -- blocca proteggi foglio----------------------------
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True
       

End Sub


Prova...

[raimea]

ciao
tutto ok

grazie

e BUONE FESTE

ciao

[raimea]

ciao
questa macro funziona

Codice: Seleziona tutto

Sub ConsecFlex()
Dim strVP As String, i As Long, J As Long, Ck As String
Dim lDiff As Long, oArr()
'------------------
' serve compilare tabella consecutivita fgl Tabelle
' pc - facile   gennaio 23
'  http://www.pc-facile.com/forum/viewtopic.php?f=26&t=112784&p=663028#p663028
'----------------------
Worksheets("Tabelle").Unprotect   ' togli protez

maxx = Application.WorksheetFunction.Max(Sheets("Tabelle").Range("AC:AC"))

ReDim oArr(1 To maxx, 1 To 2)
strVP = Application.WorksheetFunction.TextJoin("", True, Sheets("generale").Range("K8:K10000"))

For i = maxx To 1 Step -1
    For J = 1 To 2
        If J = 1 Then Ck = "V" Else Ck = "P"
        lDiff = Len(strVP) - Len(Replace(strVP, String(i, Ck), "", , , vbTextCompare))
        If lDiff > 0 Then
            oArr(i, J) = lDiff / i
            strVP = Replace(strVP, String(i, Ck), "###", , , vbTextCompare)
        End If
    Next J
Next i

Sheets("Tabelle").Range("AD7").Resize(maxx, 2).Value = oArr

  '-------coloro riga si no --------------------------------
   
      For Z = 7 To Cells(Rows.Count, "AC").End(xlUp).Row  ' 7 1ma riga
   
    Range("AC7:AE1000").Interior.ColorIndex = 2  '<<< sfondo bianco
    Range("AC7:AE1000").Font.Bold = False
    Next Z
   
    For RR = 7 To Z Step 2
       Range("AC" & RR & ":AE" & RR).Interior.ColorIndex = 8 ' azzurro chiaro
       Range("AC" & RR & ":AE" & RR).Font.Bold = True
    Next RR

' -- blocca proteggi foglio----------------------------
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True
       

End Sub

ora dovrei fare gli stessi conteggi
con gli stessi riferimenti e nome fogli

MA
anzicche cercare e contare le lettere V _ P

deve cercare contare la frase Vinta _ Persa

ho provato a modivicare V=Vinta e P=Persa

ma non fa i conteggi corretti

ciao

[Anthony47]

1) Ho modificato le istruzioni marcate ** in questo blocco:

Codice: Seleziona tutto

    For J = 1 To 2
        If J = 1 Then Ck = "Vinta" Else Ck = "Persa"                                        '**
        lDiff = Len(strVP) - Len(Replace(strVP, StringW(i, Ck), "", , , vbTextCompare))     '**
        If lDiff > 0 Then
            oArr(i, J) = lDiff / i / Len(Ck)                                                '**
            strVP = Replace(strVP, StringW(i, Ck), "###", , , vbTextCompare)                '**
        End If
    Next J


2) Ho aggiunto questa funzione:

Codice: Seleziona tutto

Function StringW(ByVal hMany As Long, ByVal lStr As String) As String
Dim lWk As String, lI As Long
'
For lI = 1 To hMany
    lWk = lWk & lStr
Next lI
StringW = lWk
End Function


A occhio mi sembra che dia risultati ...verosimili

[raimea]

ciao
e' tutto ok

grazie mille