conta le quote

[raimea]

ciao

tramite macro
vorrei contare quante volte ho usato la stessa quota
di fgl generale col J
e riportarla in fgl squadre col H e I
mettendo in alto la quota usata piu volte

in fgl squadre vorrei fossere scritte/riportare , SOLO
le quote trovate in fgl generale


vi allego il file

https://www.dropbox.com/scl/fi/u3r28d7k7pqaqoaivh731/quote.xlsm?dl=0&rlkey=9rzr6z5hq8tswlxk1rirbxoyh

ciao

[Anthony47]

Non sono certo di aver capito, ma prova questa macro:

Codice: Seleziona tutto

Sub QuoteNSort()
Dim wArr, StaQ As Range, myMatch, OutR As Range
Dim oArr(), oInd As Long, tArr(1 To 2)
'
Set StaQ = Sheets("generale").Range("J8")       '<<< Da dove leggere le quote
Set OutR = Sheets("Squadre").Range("O7")        '<<< Dove scrivere il risultato
'
wArr = Range(StaQ, StaQ.End(xlDown)).Value
ReDim oArr(1 To UBound(wArr), 1 To 2)
oInd = 1
For I = 1 To UBound(wArr)
    myMatch = Application.Match(wArr(I, 1), Application.WorksheetFunction.Index(oArr, 0, 1), False)
    If IsError(myMatch) Then
        oArr(oInd, 1) = wArr(I, 1)
        oArr(oInd, 2) = 1
        oInd = oInd + 1
    Else
        oArr(myMatch, 2) = oArr(myMatch, 2) + 1
    End If
Next I
'Ordinamento in bubble sort:
For I = 1 To oInd - 1
    For J = I + 1 To oInd
        If oArr(I, 2) < oArr(J, 2) Then
            tArr(2) = oArr(I, 2)
            tArr(1) = oArr(I, 1)
            oArr(I, 2) = oArr(J, 2)
            oArr(I, 1) = oArr(J, 1)
            oArr(J, 2) = tArr(2)
            oArr(J, 1) = tArr(1)
        End If
    Next J
Next I
Range(OutR, OutR.Offset(10000, 0).End(xlUp)).Resize(, 2).ClearContents
OutR.Resize(UBound(oArr), 2).Value = oArr
End Sub


Questa legge le quote da foglio GENERALE e le scrive su foglio SQUADRE in ordine decrescente di presenza

Le linee marcate <<< sono da personalizzare; al momento ho impostato l'output su un'area libera; se il risultato e' quello che cercavi allora bastera' correggere la riga Set OutR = Etc Etc

Se cercavi una cosa diversa allora devi spiegare meglio...

[raimea]

ciao

e' tutto ok

ho sistemato dove riportare il risultato

grazie

[raimea]

ciao
ho resettato il fgl generale x partire con i dati nel nuovo mese di Dicembre

ma la macro mi va in blocco,
non termina mai se scrivo 1na sola partita in riga 8.

mentre se x test ne scrivo solo 2/ 3 si blocca qui:







ciao

[Anthony47]

Quando si blocca e' perche' sta lavorando con una matrice lunga tutta una colonne; mentre ho capito che in certe condizioni le dimensioni di wArr e oArr rischiavano di essere in contrasto.
Ho quindi aggiunto un If /End If + un ulteriore If, le righe marcate con 'XXX nel seguente listato, e spostata la riga marcata 'SSS:

Codice: Seleziona tutto

'altro codice precedente
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=112675&p=662302#p662302
'------------------

 ActiveSheet.Unprotect
 
Set StaQ = Sheets("generale").Range("J8")       '<<< Da dove leggere le quote
Set OutR = Sheets("Squadre").Range("H7")        '<<< Dove scrivere il risultato
'
Range(OutR, OutR.Offset(10000, 0).End(xlUp)).Resize(, 2).ClearContents        'SSS
If Range(StaQ, StaQ.End(xlDown)).Rows.Count < 5000 Then                       'XXX
    wArr = Range(StaQ, StaQ.End(xlDown)).Value
    ReDim oArr(1 To UBound(wArr), 1 To 2)
    oInd = 1
    For i = 1 To UBound(wArr)
        myMatch = Application.Match(wArr(i, 1), Application.WorksheetFunction.Index(oArr, 0, 1), False)
        If IsError(myMatch) Then
            oArr(oInd, 1) = wArr(i, 1)
            oArr(oInd, 2) = 1
            oInd = oInd + 1
        Else
            oArr(myMatch, 2) = oArr(myMatch, 2) + 1
        End If
        DoEvents
    Next i
    'Ordinamento in bubble sort:
    If oInd > UBound(wArr) Then oInd = oInd - 1       'XXX
    For i = 1 To oInd - 1
        For J = i + 1 To oInd
            If oArr(i, 2) < oArr(J, 2) Then
                tArr(2) = oArr(i, 2)
                tArr(1) = oArr(i, 1)
                oArr(i, 2) = oArr(J, 2)
                oArr(i, 1) = oArr(J, 1)
                oArr(J, 2) = tArr(2)
                oArr(J, 1) = tArr(1)
            End If
        Next J
    Next i
''    Range(OutR, OutR.Offset(10000, 0).End(xlUp)).Resize(, 2).ClearContents
    OutR.Resize(UBound(oArr), 2).Value = oArr
   
End If                                              'XXX

'---- metto in ordine dal piu frequente-----------------------
    Range("H7:I1000").Select
'altro codice successivo

Richiede almeno 2 valori in colonna J (con 0 o 1 valore skippa la fase di calcolo e lascia vuota l'area su foglio Squadre; se ha senso faccio un'ulteriore modifica)

Ciao

[raimea]

ciao
tutto ok

x ora va bene cosi

grazie