L'esempio che hai fatto non mi ispira, quindi vado con qualche considerazione generale...
Intanto, l'algoritmo che hai usato e' alquanto povero; perche' non c'e' bisogno di spazzolare tutta la tabella di origine per cercare la corrispondenza di un nome (almeno dovresti aggiungere un Exit For nel momento che la trovi), ma ci sono operazioni piu' dirette, ad esempio Confronta (Match) o Cerca.Vert (Vlookup) che puntano rapidamente alla riga.
Sempre nell'ottica della velocita' bisognerebbe puntare a evitare di ripetere piu' volte lo stesso loop, se i risultati possono essere "incasellati" nella posizione giusta in un unico loop.
Ad esempio, vedi file scaricabile qui:
https://www.dropbox.com/s/87h3bc9j3zs6e ... .xlsm?dl=0In Foglio2 ho modificato il contenuto della tua tabella in modo da avere circa 4000 righe con Nomi ripetuti; supponiamo ora di voler creare un riepilogo sullo stesso foglio con l'elenco unico dei Nomi e la somma delle rispettive quantita'.
Possiamo usare questa macro che usa un algoritmo con un solo ciclo sulla tabella di partenza:
- Codice: Seleziona tutto
Sub Riepiloga()
Dim RPos As String, myMatch, I As Long
Dim BTab As String, J As Long, myTim As Single
'
RPos = "H1" '<<< Destinazione
BTab = "A1" '<<< Partenza
'
myTim = Timer
Range(RPos).CurrentRegion.ClearContents
Range(RPos).Resize(1, 2) = Array("Nome", "Somma Qt")
J = 2
Application.ScreenUpdating = False
For I = 2 To Range(BTab).Offset(Rows.Count - 10, 0).End(xlUp).Row
myMatch = Application.Match(Cells(I, "A").Value, Range(RPos).Resize(J, 1), False)
If IsError(myMatch) Then 'No match, valore non presente in tabella
Range(RPos).Offset(J - 1, 0).Value = Cells(I, "A").Value
Range(RPos).Offset(J - 1, 1).Value = Cells(I, "B").Value
J = J + 1
Else 'Valore gia' presente in tabella
Range(RPos).Offset(myMatch - 1, 1).Value = Range(RPos).Offset(myMatch - 1, 1).Value + Cells(I, "B").Value
End If
Next I
Debug.Print Format(Timer - myTim, "0.00") 'Tempo necessario
Application.ScreenUpdating = True
Beep
End Sub
Qui usiamo Match (nella versione Application.Match, non Application.WorksheetFunction.Match) per controllare se un Nome e' gia' nel riepilogo; se c'e' aggiorniamo i valori, altrimenti si aggiunge e si mette il valore iniziale
Application.Match restituisce un risultato di errore se la voce cercata manca in elenco; la variante teoricamente piu' corretta WorksheetFunction.Match restituisce invece un run-time error, che e' piu' trigoso da gestire.
Se le righe sono tante ma tante, allora conviene creare in memoria una matrice copia dei dati di partenza e scorrere poi questa matrice invece che i dati di origine. Idem invece di scrivere volta per volta nella tabella dei risultati possiamo crearci una matrice in memoria e poi scrivere tutto insieme sul foglio
Ad esempio:
- Codice: Seleziona tutto
Sub Riepiloga2()
Dim RPos As String, myMatch, I As Long
Dim BTab As String, J As Long, myTim As Single
Dim WorkArr, ONArr(), OVArr()
'
RPos = "H1" '<<< Destinazione
BTab = "A1" '<<< Partenza
'
myTim = Timer
Range(RPos).CurrentRegion.ClearContents
Range(RPos).Resize(1, 2) = Array("Nome", "Somma Qt")
J = 1
'Copia in WorkArr la tabella di partenza)
WorkArr = Range(Range(BTab).Offset(1, 0), Range(BTab).Offset(Rows.Count - 10, 1).End(xlUp)).Value
'Ridimensiono le matrici di Output
ReDim ONArr(LBound(WorkArr, 1) To J + 1) 'Array dei Nomi, corta e poi ridimensionata
ReDim OVArr(LBound(WorkArr, 1) To UBound(WorkArr, 1)) 'Array dei valori, lunga quanto i dati di partenza
'
'Spazzolo il contenuto di WorkArr:
For I = 1 To UBound(WorkArr)
myMatch = Application.Match(WorkArr(I, 1), ONArr, False) 'Confronto con la matrice dei Nomi
If IsError(myMatch) Then 'No match, valore non presente in matrice
ONArr(J) = WorkArr(I, 1) 'Aggiungo in matrice Nomi e matrice Valori
OVArr(J) = WorkArr(I, 2)
J = J + 1
ReDim Preserve ONArr(1 To J + 1)
Else 'Valore gia' presente in matrice, incrementa il valore
OVArr(myMatch) = OVArr(myMatch) + WorkArr(I, 2)
End If
Next I
Range(RPos).Offset(1, 0).Resize(J, 1) = Application.WorksheetFunction.Transpose(ONArr) 'Scrive in blocco i Nomi
Range(RPos).Offset(1, 1).Resize(J, 1) = Application.WorksheetFunction.Transpose(OVArr) 'Scrive in blocco i valori
'
Debug.Print Format(Timer - myTim, "0.00") 'Tempo necessario
Beep
End Sub
Qui vediamo che inizialmente popoliamo la variante WorkArr con la matrice dei valori di tabella (WorkArr = Range etc etc)
Vediamo anche che Match puo' avere come target una matrice, non necessariamente un Range; pero' solo una matrice monodimensionale. Quindi per i nomi da creare mi appoggio sulla matrice ONArr e per i valori a una OVArr "parallela"
Una curiosita': la ONArr la dimensiono corta e poi la ridimensiono man mano che aggiungo i nomi, mentre la OVArr la dimensiono sulla lunghezza massima teorica. Questo perche' la ONArr viene usata come intervallo dalla funzione Match, che (nella variante con parametro False) lavora sequenzialmente, quindi una matrice corta accorcia i tempi di esecuzione.
Alla fine, ONArr e OVArr devono essere trasformati da matrice orizzontale in matrice verticale e possono essere "pompati" nell'intervallo di destinazione (l'area del risultato)
Tieni presente che in questo esempio ho potuto usare Match per testare se un Nome e' gia' in elenco; ma se gia' dovessi testare strutture piu' complesse potrebbe essere utile ricorrere a un "dictionary"; per una infarinatura:
viewtopic.php?t=96606 (contiene anche un link a una discussione in cui il Dictionary serve a velocizzare una ricerca, e dove viene anche richiamata un'altra struttura dati, la Collection)
In ambedue i casi, la Debug.Print a fine macro scrive nella "Finestra Immediata" del vba il tempo impiegato; per accedere alla finestra Immediata basta la combinazione Contr-g, oppure Menu /Visualizza /Finestra Immediata
Spero che trovi qualche spunto per partire con i tuoi esperimenti.
Ciao
PS: per chi ha Excel 365 con la nuova funzione UNICI, lo stesso risultato ottenuto qui con le macro dimostrative e' ottenibile con semplici formula, come mostrato sempre su Foglio2 del file dimostrativo linkato prima
