I più frequenti

[giorgioa]

salve
delle estrazioni del 10 e lotto ho concatenato per terno i 20 numeri di ogni riga per un totale di 1140
celle per riga per 200 circa;
da questo intervallo intervallo d7:oqz200 (sono solo dati)vorrei estrapolare i terni più frequenti
indicando ad esempio in una casella d5 che abbiano frequenza 3 oppore 4, 5 ecc e nel contempo
ottenere di queste frequenze anche il relativo terno.
Si può fare con una formula? oppure serve una macro?
Mi potete indicare come? Tenuto conto che il sottoscritto di VBA non ne capsce niente.
Grazie dell'interessamento e non...

[Flash30005]

Secondo me c'è un errore di fondo
i terni sviluppati da 90 numeri sono 117.480
e sono questi che dovrebbero essere riportati in un foglio (Foglio2 da A1 a C117480)
Nel foglio1 inserirai l'archivio del 10&lotto (le 200 righe)
poi con questa macro

Codice: Seleziona tutto

Sub ContT()
Set Ws1 = Sheets("Foglio1")
Set Ws2 = Sheets("Foglio2")
Application.Calculation = xlManual
Ws2.Columns("E:E").ClearContents
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 1 To UR2
Terno2 = ""
For CC2 = 1 To 3
Terno2 = Terno2 & Format(Ws2.Cells(RR2, CC2).Value, "00")
Next CC2
For RR1 = 1 To UR1
For CC1a = 1 To 18
If Ws2.Cells(RR2, 1).Value < Ws1.Cells(RR1, CC1a).Value Then GoTo SaltaRR2
For CC1b = CC1a + 1 To 19
If Ws2.Cells(RR2, 2).Value < Ws1.Cells(RR1, CC1b).Value Then GoTo SaltaRR2
For CC1c = CC1b + 1 To 20
If Ws2.Cells(RR2, 3).Value < Ws1.Cells(RR1, CC1c).Value Then GoTo SaltaRR2
If Terno2 = Format(Ws1.Cells(RR1, CC1a).Value, "00") & Format(Ws1.Cells(RR1, CC1b).Value, "00") & Format(Ws1.Cells(RR1, CC1c).Value, "00") Then
    Ws2.Range("E" & RR2).Value = Ws2.Range("E" & RR2).Value + 1
    GoTo SaltaRR2
End If
Next CC1c
Next CC1b
Next CC1a
Next RR1
SaltaRR2:
Next RR2
Application.Calculation = xlCalculationAutomatic
End Sub

Avrai nella colonna E le frequenze per singolo terno
alla fine ordinerai le colonne A:E nel foglio2 in ordine decrescente

Allego file con macro
Il file non contiene tutte le combinazione dei terni per via della limitazione delle righe in excel 2003 (65.000 circa)
a tal proposito allego il file testo di tutte le combinazioni in terni dei 90 numeri
Terni
il file testo va importato nel foglio2 usando la funzione "Testo in Colonne" con separatore "virgola"

Ciao

[giorgioa]

Salve Flash, grazie dell'interessamento.
Preciso che in tempi remoti ho fatto quanto mi hai descritto
cioè ho sviluppato le 117 e passa combinazioni integrali e con quel sistema
che mi hai illustrato cercavo fermi restando che comunque dovevo sviluppare
dia 20 numeri le terne occorrenti cioè 1140.
Il problema nasce dalla lentezza di ricavare i dati nel senso che quando aprivo il
file già predisposto alla ricerca e poi per mettere i dati in modo decresente.
Mi sono detto che invece di sviluppare 117.000 combinazioni visto che sviluppo
le combinazioni di 20 e non 90 numeri resta poi il problema della ricerca
delle terne più frequenti.
Per maggiore precisione metto i dati dove sono collocate le terne sviluppate
delle 200 estrazioni.
cioè E7:AQZ200.
Fammi sapere se sono stato chiaro e se il mio discorso è avvettabile.
Saluti Giorgioa

[Flash30005]

E' tutto corretto quello che dici se uscissero sempre le stesse 1140 terzine
Siccome, chiaramente, non è così avrai inizialmente con una estrazione 1140
con due estrazioni anche 2280 e...
con 200 estrazioni anche 228.000 terzine (di cui 110520 ripetute) e ne rimangono
117480 cioè le combinazioni di terzine su 90 numeri.
Hai provato a farlo con la macro (o meglio con il file) che ti ho inviato?
I tempi come sono?

ciao

EDIT ore 17:00

Non so come hai concatenato le terzine ovvero se hai usato un separatore (es. la virgola o altro)
Se hai usato un separatore puoi utilizzare il conta.se.
Es: Se la tua matrice inizia nella cella E7 (come dici nel post)
ti posizioni nella cella E1007 e inserisci questa formula

Codice: Seleziona tutto

=CONTA.SE($E$7:$AQZ$200;E7)-1

Poi trascini fino a E1200 e quindi (E1007:E1200) fino a AQZ1200
I numeri che troverai in questa matrice sono le ripetizioni di una determinata terzina
Potrai condizionare le celle di questa seconda matrice
se = 3 colore giallo
se = 4 colore verde
se >= 5 colore rosso
Per evidenziare le frequenze
per risalire alla riga (estrazione) corrispondende non devi far altro che detrarre 1000 alla riga di quella cella

[giorgioa]

Salve Flash.
evidentemente sono partito in quinta senza mettermi in macchina.
Cancellato tutto quello che avevo nella mente ed ho
riposto tale e quale quello che mi hai indicato,
solo che nel momento in cui lancio la macro mi chiede di dichiarare
la variabile(riga): Set Ws1 = Sheets("Foglio1").
Ho copiato col copia e incolla la macro dal tuo file
e l'ho messa nel file mio dove ho inserito
foglio2 le 117480 combinazioni mentre nel foglio1 le estrazioni su cui
intendo ricavare i dati.

Però ho fatto un' altra prova cioè dal file tu che ha la macro dal mio file
l'ho lanciata però sono stato ad aspettare 5 minuti ma l'elaborazione
non terminava.
Spero di essere stato chiaro.
Ti saluto

[Flash30005]

Sinceramente non ho capito quasi nulla
ma provo a chiarire

nel momento in cui lancio la macro mi chiede di dichiarare
la variabile(riga): Set Ws1 = Sheets("Foglio1").

Inserisci la riga di dichiarazione indicata

Codice: Seleziona tutto

Dim Ws1 As Worksheet '<<<<< questa
Set Ws1 = Sheets("Foglio1")

inoltre il foglio archivio si deve chiamare "foglio1" altrimenti va in errore (oppure cambia il nome del foglio nella macro)

Ho copiato col copia e incolla la macro dal tuo file
e l'ho messa nel file mio dove ho inserito
foglio2 le 117480 combinazioni mentre nel foglio1 le estrazioni su cui
intendo ricavare i dati.

qui non hai specificato cosa è successo...

Però ho fatto un' altra prova cioè dal file tu che ha la macro dal mio file
l'ho lanciata però sono stato ad aspettare 5 minuti ma l'elaborazione
non terminava.

Non capisco cosa hai fatto

Spero di essere stato chiaro.

Non tanto!

Leggi anche l'Edit delle ore 17:00 del post precedente (soluzione con formula)

Ciao

[giorgioa]

Salve Flash e buona domenica,
Insomma sono riuscito a farla funzionare(la macro) però della frequenza mi da solo le terne con valore 1
e non tutte mentre ho verificato con il conta.se che ci sono alcune terne con presenza 3.

Nel contempo ho provato a cambiare dei dati nella macro per ottenere invece i valori di ambo ma
qui non mi ha dato nessun risultato perchè evidentemente non ho cambiato i dati giusti.

[Flash30005]

Si, in effetti c'era un errore nella macro
Errore che ho corretto con questa

Codice: Seleziona tutto

Sub ContT()
Set Ws1 = Sheets("Foglio1")
Set Ws2 = Sheets("Foglio2")
Application.Calculation = xlManual
Ws2.Columns("E:E").ClearContents
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 1 To UR2
Terno2 = ""
For CC2 = 1 To 3
Terno2 = Terno2 & Format(Ws2.Cells(RR2, CC2).Value, "00")
Next CC2
For RR1 = 1 To UR1
For CC1a = 1 To 18
If Ws2.Cells(RR2, 1).Value < Ws1.Cells(RR1, CC1a).Value Then GoTo SaltaRR1
For CC1b = CC1a + 1 To 19
For CC1c = CC1b + 1 To 20
If Terno2 = Format(Ws1.Cells(RR1, CC1a).Value, "00") & Format(Ws1.Cells(RR1, CC1b).Value, "00") & Format(Ws1.Cells(RR1, CC1c).Value, "00") Then
    Ws2.Range("E" & RR2).Value = Ws2.Range("E" & RR2).Value + 1
    GoTo SaltaRR1
End If
Next CC1c
Next CC1b
Next CC1a
SaltaRR1:
Next RR1
Next RR2
Application.Calculation = xlCalculationAutomatic
End Sub


Ciao

[Flash30005]

Ho voluto velocizzare la ricerca utilizzando la funzione Find e quindi ho realizzato quest'altra macro che impiega 1/10 del tempo della macro precedente

Codice: Seleziona tutto

Public CC1, RC1, RR2, NT1, NT2, NT3 As Integer, Ws1, Ws2 As Worksheet

Sub TrovaT()
[T1] = Int(Timer)
Application.Calculation = xlManual
Set Ws1 = Sheets("Foglio1")
Set Ws2 = Sheets("Foglio2")
Ws2.Range("U1:V1").ClearContents
Ws2.Columns("E:E").ClearContents
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 1 To UR2
NT1 = Ws2.Range("A" & RR2).Value
NT2 = Ws2.Range("B" & RR2).Value
NT3 = Ws2.Range("C" & RR2).Value
        With Ws1.Range("A1:T" & UR1)
            Set C = .Find(NT1, LookIn:=xlValues, LookAt:=xlWhole)
                If Not C Is Nothing Then
                    firstAddress = C.Address
                    RC1 = C.Row
                    CC1 = C.Column
                    Call Confronta2
                    Do
                        Set C = .FindNext(C)
                        If firstAddress = C.Address Then Exit Do
                        RC1 = C.Row
                        CC1 = C.Column
                    Call Confronta2
                    Loop While Not C Is Nothing And C.Address <> firstAddress
                End If
        End With
Next RR2
[U1] = Int(Timer)
[V1] = [U1] - [T1]
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Confronta2()
    For CC2 = CC1 + 1 To 19
    If NT2 = Ws1.Cells(RC1, CC2).Value Then
        For CC3 = CC2 + 1 To 20
            If NT3 = Ws1.Cells(RC1, CC3).Value Then
                Ws2.Range("E" & RR2).Value = Ws2.Range("E" & RR2).Value + 1
                GoTo Esci
            End If
        Next CC3
    End If
    Next CC2
Esci:
End Sub


Ciao

[giorgioa]

Salve Flash,
ho provato la prima macro che mo hai posto,
il suo funzionamento pare che vada bene
(ho visto che riconosce anche le frequenze da 4 però
è lentissima infatti per controllare appena 3900 combinazioni circa
ha impiegato più di 35-40 minuti figuriamoci fino ad arrivare a 117480.

Ho poi copiato la seconda macro con FIND e quando la lancio mi da errore di
RUN TIME 424 necessario oggetto nella rigra di confronta2
If NT2 = Ws1.Cells(RC1, CC2).Value Then
diventa gialla di più non so.

Forse mi sto complicando la vita con la ricerca delle frequenze sui terni,
ti dispiace se ripieghiamo sugli ambi?
Cioè lo stesso concetto ma invece di ricercare terni cerca ambi frequenti.
Perchè questa ricerca è mirata al 10 e Lotto ogni 5 minuti,
quindi occorendo diverso tempo per la ricerca e poi finchè arrivo in ricevitoria
le cose si fanno troppo lunghe.
Aspetto tue nuove e ti saluto.

[Flash30005]

La prima macro impiega circa 6 ore per 200 estrazioni
La seconda macro impiega 30 minuti circa
Elaborazione effettuata con Office 2003 e pentium IV 2,5 GHz
considera che office 2007/2010 impiega da 2 a 3 volte questo tempo anche con dual core

La seconda macro va copiata integralmente compresa la riga Public
che deve essere in cima al modulo
Ti consiglio di mettere in un modulo tutto il codice della seconda macro
e se vuoi anche la prima macro inseriscila in un altro modulo

Riprova per cortesia

Poi modifichiamo per l'ambo

ciao

EDIT ore 23:15

[Flash30005]

Leggi anche il post precedente
questa è la macro ricerca ambi posti sul foglio2 dalla riga 1 alla riga 4005

Codice: Seleziona tutto

Public CC1, RC1, RR2, NT1, NT2, NT3 As Integer, Ws1, Ws2 As Worksheet
Sub TrovaT()
[T1] = Int(Timer)
Set Ws1 = Sheets("Foglio1")
Set Ws2 = Sheets("Foglio2")
Ws2.Range("U1:V1").ClearContents
Ws2.Columns("E:E").ClearContents
Application.Calculation = xlManual  '<<<<<<<<<<<< Spostata qui la riga codice
Application.ScreenUpdating = False  '<<<<<<<<<<<<<<<< aggiunta riga
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 1 To UR2
NT1 = Ws2.Range("A" & RR2).Value
NT2 = Ws2.Range("B" & RR2).Value
'NT3 = Ws2.Range("C" & RR2).Value
        With Ws1.Range("A1:T" & UR1)
            Set C = .Find(NT1, LookIn:=xlValues, LookAt:=xlWhole)
                If Not C Is Nothing Then
                    firstAddress = C.Address
                    RC1 = C.Row
                    CC1 = C.Column
                    Call Confronta2
                    Do
                        Set C = .FindNext(C)
                        If firstAddress = C.Address Then Exit Do
                        RC1 = C.Row
                        CC1 = C.Column
                    Call Confronta2
                    Loop While Not C Is Nothing And C.Address <> firstAddress
                End If
        End With
Next RR2
[U1] = Int(Timer)
[V1] = [U1] - [T1]
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True    '<<<<<<<<<<<<<<<< aggiunta riga
End Sub
Sub Confronta2()
    For CC2 = CC1 + 1 To 20
    If NT2 = Ws1.Cells(RC1, CC2).Value Then
        Ws2.Range("E" & RR2).Value = Ws2.Range("E" & RR2).Value + 1
        GoTo Esci
    End If
    Next CC2
Esci:
End Sub

Impiega circa 2 minuti per 200 estrazioni

Allego file con le combinazioni ambi

Ciao

EDIT ore 23:50 - Modificata macro: Aggiunto righe codice per accelerare l'elaborazione, Adesso per tutte le estrazioni di una giornata (224) impiega 90 secondi

[giorgioa]

Ho scaricato il file per l'ambo solo volevo sapere se le combinazioni
le devo dividere in colonne (2) o devono rimanere in una unica colonna?

[Flash30005]

Ho modificato l'ultima macro (leggi Edit e sostituisci alla precedente)

I numeri devono essere ognuno per colonna (su due colonne)
per fare questo:
Apri il file testo
selezioni tutto (dal menu Modifica -> Seleziona tutto)
Copi
ti posizioni sulla cella A1 del foglio2
e incolli
poi dal menu dati
selezioni "Testo in colonne" con separatore virgola

Poi avvii la macro dal foglio2 con un pulsante o altro

Allego File

ciao

EDIT ore 01:40 - Ho allegato il file finale che permette di elaborare sia gli ambi sia i terni in maniera indipendente.
La prima volta che si avvia (con archivio di 224 colonne) il tempo stimato per i Terni è di circa 20 minuti ma se si aggiunge una estrazione la macro prenderà in considerazione solo l'estrazione aggiunta (le colonne V e W sul foglio "Archivio" servono proprio a questo) pertanto il foglio "Terni" verrà aggiornato in pochi secondi.
A tal proposito la colonna E (conteggio Ambi e Terni) non viene cancellata se non premendo prima il comando "Reset"
Il comando Reset cancella anche le colonne V (in caso di ambi) e W (in caso di terni) del foglio Archivio

[giorgioa]

Salve Flash sono spiacente ma suoi terni non credo che si possa fare.
Pensa che ho impiegato 35-40 minuti di elaborazione e ad un certo punto
ho dovuto interrompere l'elaborazione e ho controllato a che riga era arrivato
cioè alla riga 75000.
Mentre per l'ambo va tutto OK circa 3 minuti.

Ti volevo chiedere (se non ti reco troppo disturbo) se puoi farmi incolonnare l'archivio dalla colonna
dalla C in poi perchè quando scarico col copia DA LOTTOMATICA SONO COSTRETTO A portarmi
appresso anche il numero di estrazione che porrei nella colonna B mentre nella A ho scritto
l'ora di estrazione.
Ti ringrazio

[Flash30005]

Per non sbagliare
copia tutto il codice (con l'apposito pulsante "Seleziona tutto")
e sostituisci l'intera macro
Cancella le colonne con la lettera "C" (la prima volta)
Ricorda di inserire dalla riga2 (A2) ciò che copi da internet

Codice: Seleziona tutto

Public CC1, RC1, RR2, NT1, NT2, NT3 As Integer, Ws1, Ws2 As Worksheet, NFoglio As String
Sub TrovaT()
[T1] = Int(Timer)
Set Ws1 = Sheets("Archivio")
NFoglio = ActiveSheet.Name
Set Ws2 = Sheets(NFoglio)
Ws2.Range("U1:V1").ClearContents
Application.Calculation = xlManual
Application.ScreenUpdating = False
UR1 = Ws1.Range("C" & Rows.Count).End(xlUp).Row + 1
If NFoglio = "Terni" Then
    URC = Ws1.Range("Y" & Rows.Count).End(xlUp).Row + 1
Else
    URC = Ws1.Range("X" & Rows.Count).End(xlUp).Row + 1
End If
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 1 To UR2
NT1 = Ws2.Range("A" & RR2).Value
NT2 = Ws2.Range("B" & RR2).Value
NT3 = Ws2.Range("C" & RR2).Value
        With Ws1.Range("C" & URC & ":V" & UR1)
            Set C = .Find(NT1, LookIn:=xlValues, LookAt:=xlWhole)
                If Not C Is Nothing Then
                    firstAddress = C.Address
                    RC1 = C.Row
                    CC1 = C.Column
                    Call Confronta2
                    Do
                        Set C = .FindNext(C)
                        If firstAddress = C.Address Then Exit Do
                        RC1 = C.Row
                        CC1 = C.Column
                    Call Confronta2
                    Loop While Not C Is Nothing And C.Address <> firstAddress
                End If
        End With
Next RR2
[U1] = Int(Timer)
[V1] = [U1] - [T1]
If NFoglio = "Terni" Then
    Ws1.Range("Y1:Y" & UR1 - 1).Value = "C"
Else
    Ws1.Range("X1:X" & UR1 - 1).Value = "C"
End If
Application.Calculation = xlCalculationAutomatic

[R1] = [Q1] / (UR1 - 2)
Application.ScreenUpdating = True
End Sub

Sub Confronta2()
UC = 22
If NFoglio = "Terni" Then UC = 21
    For CC2 = CC1 + 1 To UC
    If NT2 = Ws1.Cells(RC1, CC2).Value Then
        If NFoglio = "Terni" Then
            For CC3 = CC2 + 1 To 22
                If NT3 = Ws1.Cells(RC1, CC3).Value Then
                    Ws2.Range("E" & RR2).Value = Ws2.Range("E" & RR2).Value + 1
                    GoTo Esci
                End If
            Next CC3
        Else
            Ws2.Range("E" & RR2).Value = Ws2.Range("E" & RR2).Value + 1
            GoTo Esci
        End If
    End If
    Next CC2
Esci:
End Sub
Sub Resetta()
Set Ws1 = Sheets("Archivio")
NFoglio = ActiveSheet.Name
Set Ws2 = Sheets(NFoglio)
scelta = MsgBox(Prompt:="Vuoi Resettare i Dati finora trovati sul " & NFoglio & " ?", Buttons:=vbYesNo)
If scelta = 6 Then
    Ws2.Columns("E:E").ClearContents
    If NFoglio = "Terni" Then
        Ws1.Columns("Y:Y").ClearContents
    Else
        Ws1.Columns("X:X").ClearContents
    End If
End If
End Sub


Ciao

[Flash30005]

Volendo facilitare l'aggiornamento da web
inserisci in un modulo questa macro

Codice: Seleziona tutto

Sub AggiornaDati()
Sheets("Archivio").Select
DataAgg = Date
Inizio:
GG = Day(DataAgg)
MM = Month(DataAgg)
AA = Year(DataAgg)
Pagina = AA & "-" & MM & "-" & GG
Cells.Clear
    Range("A2").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.lottologia.com/?area=10elotto5minuti&action=Archivio&date=" & Pagina _
        , Destination:=Range("A2"))
        .Name = "?area=10elotto5minuti&action=Archivio&date=2012-04-30"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").EntireColumn.AutoFit
    Columns("C:C").ColumnWidth = 2.86
    If Range("A2").Value = "" Then
    DataAgg = DataAgg - 1
    GoTo Inizio
    End If
    Range("A1").Select
End Sub


Attiva la macro con un pulsante o con un tasto di scelta rapida (tipo Ctrl+A)*

Le pagine hanno un indirizzo relativo alla data dell'estrazione pertanto nell'arco della giornata non ci sono problemi ma nel caso di aggiornamento archivio oltre la mezzanotte e prima delle ore 5:00, si incontrerebbero problemi presentando un archivio vuoto.
A tal proposito ripeto il ciclo fino a trovare l'ultima giornata con dei dati,
quindi le estrazioni del/i giorno/i precedente/i.

Ciao
* Vedi post successivo

[Flash30005]

Aggiungo una "chicca"
Per avere l'aggiornamento dell'Archivio inserisci sul foglio questo codice

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = "$A$1" Then Call AggiornaDati
Range("A1").Interior.ColorIndex = 6
Range("B1").Select
End Sub


Con DoppioClick sulla cella A1 avrai l'archivio aggiornato
e la cella A1 torna ad essere evidenziata per ricordare che è una cella "particolare"

Ciao

[giorgioa]

Ok Flash questa sera ti dirò se tutto va bene.
Ti saluto

[Flash30005]

Ok
comunque visto che si tende a migliorare sempre
ho approntato il file che allego
che è autoaggiornante
non ha bisogno di reset e
aggiorna solo le estrazioni mancanti nell'arco della giornata
altrimenti aggiorna tutto.
Tempi elaborazione:
per gli ambi sono 90/100 secondi (per office 2007/2010 circa il doppio)
per i terni sono 3600 secondi (un'ora) per l'archivio di una giornata quindi 15/20 secondi per ogni estrazione aggiunta

Download file

Ciao

Aggiungo: questo codice da inserire nel modulo

Codice: Seleziona tutto

Sub OrdinaFreq()

    Columns("A:E").Sort Key1:=Range("E1"), Order1:=xlDescending, Key2:=Range("A1") _
        , Order2:=xlAscending, Key3:=Range("B1"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
End Sub


E il richiamo a questa macro prima della fine macro "TrovaT"

Codice: Seleziona tutto

Ws2.Range("I2").Value = Ws1.Range("B" & UR1 - 1).Value   '<<<<<<<<<< Esistente
OrdinaFreq        '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<Aggiungere qui
Application.Calculation = xlCalculationAutomatic         '<<<<<<<<<< Esistente
[R1] = [Q1] / (UR1 - 2)      '<<<<<<<<<< Esistente
Application.ScreenUpdating = True     '<<<<<<<<<< Esistente
End Sub

In maniera da ottenere l'ordinamento decrescente delle frequenze per tipo di Ambo