Macro funzionante ma lentissima

Hai un problema con Excel?

Nuova discussione

Macro funzionante ma lentissima
di Daniela (utente non iscritto) data: 22/12/2017 10:01:15
Buongiorno a tutti, e buongiorno a Patel che mi è sempre di grande aiuto.

Qualche tempo fa ho posto una questione e Patel mi ha aiutato con la macro sotto, che gira bene e fa quello che deve fare, ma ci mette un'infinità di tempo.
Su files piccoli infatti nessun problema, ma io devo confrontare 60.000 celle con altre 600.000 (per foglio - in realtà con 5.000.000 di celle in tutto) e impiego più di 5 ore a far lavorare la macro, è normale (quindi solo su 600.000 celle)??

Se volete posso fornirvi un file con i 2 fogli con le celle da matchare con tutti i dati, ma è enorme.

magari non esistono soluzioni più veloci, però provare a chiedere non costa nulla!

GRAZIEE

Sub cerca1()
Dim Lrow As Long, LR As Long, c As Range, Ir As Long, ISRC As String
Application.ScreenUpdating = False
Lrow = Sheets("Conflitti").Range("A" & Rows.Count).End(xlUp).Row
LR = Sheets("Tutti4").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Tutti4").Range("A:A").Interior.ColorIndex = xlNone
For Ir = 2 To Lrow
  ISRC = Sheets("Conflitti").Cells(Ir, 4)
  With Sheets("Tutti4").Range("E2:E" & LR)
    Set c = .Find(ISRC, LookIn:=xlValues)
    If Not c Is Nothing Then c.Offset(0, -4).Interior.ColorIndex = 4
  End With
Next Ir
Application.ScreenUpdating = True

MsgBox "Terminato"
End Sub

di Mister_x (utente non iscritto) data: 22/12/2017 12:31:23
ciao

se nel file in questione hai moltissime formule il file diventa molto lento in quanto deve coalcolare le formule ogni volta tu modifichi una cella
prova a mettere queste due righe di codice

ciao

qui
Application.ScreenUpdating = False
  Application.Calculation = xlManual   ''sospende il calcolo delle formule
Lrow = Sheets("Conflitti").Range("A" & Rows.Count).End(xlUp).Row

e qui
Next Ir
    Application.Calculation = xlAutomatic  ''riattiva il calcolo automatico
    Calculate  '' forza un calcolo = F9 su un foglio di excel
Application.ScreenUpdating = True

di Daniela (utente non iscritto) data: 22/12/2017 12:33:32
Ciao MIster_X

in effetti i file sono privi di formule... solo dati dati dati dati...... una marea di dati
di Zer0Kelvin data: 22/12/2017 15:01:59
Ciao.
Forse si potrebbe fare qualcosa, ma occorrerebbe un file (ridotto, possibilmente, ma non troppo

) su cui fare dei test.
di patel data: 22/12/2017 17:48:08
Ciao Zer0Kelvin, qual'è la tua idea ?
di Zer0Kelvin data: 22/12/2017 19:54:00
In realtà non ne ho ancora una; si potrebbero usare dei vettori oppure una ricerca binaria se almeno una delle due liste è ordinata...
Bisognerebbe vedere il file.

di Marius44 data: 22/12/2017 23:14:56
Buonasera a tutti
Qualche tempo fa elaborai questo codice che, in due Fogli differenti, confronta la col.A del primo (circa 600 valori) con la col.A del secondo (circa 9000 valori) in un batter d'occhi. Ovviamente non posso sapere quanto impiegherebbe con milioni di dati ma tentar non nuoce.

Prova ad adattarlo alle tue esigenze. Per una prova ti allego il file

Fai sapere. Ciao,
Mario

Option Explicit

Sub ColoraCelleUguali()
'by Marius44
Dim i As Long, j As Long, uriga1 As Long, uriga2 As Long
Dim wks1 As Worksheet, wks2 As Worksheet
Dim Rng As Range
Dim RP, SH, itime, ftime

itime = Timer
Application.ScreenUpdating = False
Set wks1 = ThisWorkbook.Worksheets("Foglio1")
Set wks2 = ThisWorkbook.Worksheets("Foglio2")

Sheets("Foglio1").Select
uriga1 = wks1.Range("A" & Rows.Count).End(xlUp).Row
RP = wks1.Range(Cells(2, 1), Cells(uriga1, 1)).Value    ''''

Sheets("Foglio2").Select
Set Rng = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Rng.Interior.ColorIndex = xlNone
uriga2 = wks2.Range("A" & Rows.Count).End(xlUp).Row
SH = wks2.Range(wks2.Cells(2, 1), wks2.Cells(uriga2, 1)).Value

For i = 2 - 1 To uriga1 - 1
    If RP(i, 1) <> "" Then
        For j = 2 - 1 To uriga2 - 1
            If RP(i, 1) = SH(j, 1) Then
                wks2.Cells(j, 1).Interior.ColorIndex = 4
            End If
        Next j
   End If
Next i

Set wks1 = Nothing
Set wks2 = Nothing
ftime = Timer
Cells(2, 5) = ftime - itime
Application.ScreenUpdating = True
MsgBox "Fatto!", vbExclamation
End Sub

di Daniela (utente non iscritto) data: 23/12/2017 11:06:35
Ciao ragazzi scusate il ritardo,

appena posso provo la macro che mi ha indicato Marius.

Nel frattempo il file su cui provare (non troppo ridotto) è di 30 mb. con 1 foglio da 600.000 righe su cui confrontare circa 20.000 celle. Provo ad allegarvi un link con i dovuti spazi:

www dropbox com/s/9yxs1lrnusebcus/Tutti2016_FOGLI_isrc%20-PROVA%20RIDOTTA.xlsm?dl=0
di Zer0Kelvin data: 23/12/2017 23:37:15
Non riesco a scaricare il file,il copia/incolla ha alterato il link, che caratteri sono quelli indicati come %20

Non riesci a caricare il file sul forum (tasto "Allega un file")?
di isy data: 24/12/2017 00:11:31
Ciao Zer0Kelvin

Cit: Non riesco a scaricare il file,il copia/incolla ha alterato il link
Io ho solo inserito la punteggiatura in "www dropbox com" per scaricare il file.

di Marius44 data: 24/12/2017 11:55:41
Ciao Daniela
Ti posto la macro "adattata" per il file da te allegato.
Ho notato che ogni 9 valori (cicli) del Foglio1 impiega 1 sec. circa. Visto che ci sono poco più di 27000 righe dovrebbe impiegare poco meno di un'ora.

Ciao,
Mario

Sub ColoraCelleUguali()
'by Marius44
Dim i As Long, j As Long, uriga1 As Long, uriga2 As Long
Dim wks1 As Worksheet, wks2 As Worksheet
Dim Rng As Range
Dim RP, SH, itime, ftime

itime = Timer
Application.ScreenUpdating = False
Set wks1 = ThisWorkbook.Worksheets(1)
Set wks2 = ThisWorkbook.Worksheets(2)

Sheets(1).Select
uriga1 = wks1.Range("A" & Rows.Count).End(xlUp).Row
RP = wks1.Range(Cells(2, 1), Cells(uriga1, 1)).Value    ''''

Sheets(2).Select
Range("A:A").Interior.ColorIndex = xlNone
Set Rng = Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
uriga2 = wks2.Range("E" & Rows.Count).End(xlUp).Row
SH = wks2.Range(wks2.Cells(2, 5), wks2.Cells(uriga2, 5)).Value
wks1.Cells(2, 8) = Now
For i = 2 - 1 To uriga1 - 1
    If RP(i, 1) <> "" Then
        For j = 2 - 1 To uriga2 - 1
            If RP(i, 1) = SH(j, 1) Then
                wks2.Cells(j, 1).Interior.ColorIndex = 4
            End If
        Next j
   End If
Next i
wks1.Cells(3, 8) = Now
Set wks1 = Nothing
Set wks2 = Nothing
ftime = Timer
Cells(5, 8) = ftime - itime
Application.ScreenUpdating = True
MsgBox "Fatto!", vbExclamation
End Sub

di Zer0Kelvin data: 24/12/2017 16:18:25
Probabilmente mi sfugge qualcosa, perchè la routine qui sotto impiega una dozzina di secondi ad effettuare tutti i confronti col file di esempio.
Se ho capito bene, bisogna confrontare tutti i valori in colonna E del foglio 2 con ogni valore in colonna A del foglio 1.
Col file di esempio, comunque, non ottengo nessun riscontro positivo ma , se inserisco dei valori corrispondenti in colonna E, la routine li trova.

Public Sub Colora_Celle()
Dim S1 As Worksheet, S2 As Worksheet
Dim V1 As Variant, V2 As Variant
Dim uR1 As Long, uR2 As Long, R1 As Long, R2 As Long
Dim T1 As Single
'------------------------------------
T1 = Timer
Set S1 = Sheets("Foglio1")
Set S2 = Sheets("Tutti2016_1")
With S1
    uR1 = .Cells(Rows.Count, "A").End(xlUp).Row
    V1 = .Range("A1:A" & uR1)
End With
With S2
    uR2 = .Cells(Rows.Count, "E").End(xlUp).Row
    V2 = .Range("E1:E" & uR2)
End With
S2.Range("A:A").Interior.ColorIndex = xlNone
For R1 = 2 To uR1
    For R2 = 2 To uR2
        If V1(R1, 1) = V2(R2, 1) Then
            S2.Cells(R2, 1).Interior.ColorIndex = 4
        End If
    Next R2
Next R1
MsgBox Format((uR1 - 1) * (uR2 - 1), "standard") & "  confronti" & vbCrLf & "in: " & Timer - T1 & "  secondi."
Set S1 = Nothing
Set S2 = Nothing
End Sub

di Daniela (utente non iscritto) data: 27/12/2017 09:24:12
Ciao ragazzi, auguri passati intanto e grazie.

Provo le ultime 2 macro che mi avete inviato e vi dico.

di Daniela (utente non iscritto) data: 27/12/2017 11:19:35
Benissimo la macro di Marius44 che effettivamente ha impiegato 1ora e 4 min per il matching!!

Grazie mille!!

L'altra invece mi causava un blocco in excel... forse stava lavorando, ma data l'indicazione dei 20 secondi di lavorazione, a un certo punto ho staccato. non so!!

Un'ultima domanda e poi vi lascio in pace....

Posso concatenare la ricerca su diversi fogli? mi spiego, quello che vi ho mandato in esempio diciamo che è il file su cui devo lavorare, che inoriginale, però, presenta in tutto 10 fogli da confrontare (ognuno per 600.000 righe)
Visto che la macro ora gira velocemente potrei pensare di far partire a fine giornata una ricerca su tutti e 10 i fogli in modo ch eimpiega quello che impiega (10 ore ad esempio) ma mi interroga tutto il file.

Posso scrivere un codice unico o devo forzatamente duplicare quello già dato cambiando il numero del foglio "Tutti2016_1" con _2 _3 etc etc (vedi codice, che non so se funzionerebbe)??
Questa è ignoranza lo so....

Sub ColoraCelleUguali()
'by Marius44
Dim i As Long, j As Long, uriga1 As Long, uriga2 As Long
Dim wks1 As Worksheet, wks2 As Worksheet
Dim Rng As Range
Dim RP, SH, itime, ftime

itime = Timer
Application.ScreenUpdating = False
Set wks1 = ThisWorkbook.Worksheets("Foglio1")
Set wks2 = ThisWorkbook.Worksheets("Tutti2016_1")

Sheets(1).Select
uriga1 = wks1.Range("A" & Rows.Count).End(xlUp).Row
RP = wks1.Range(Cells(2, 1), Cells(uriga1, 1)).Value    ''''

Sheets(2).Select
Range("A:A").Interior.ColorIndex = xlNone
Set Rng = Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
uriga2 = wks2.Range("E" & Rows.Count).End(xlUp).Row
SH = wks2.Range(wks2.Cells(2, 5), wks2.Cells(uriga2, 5)).Value
wks1.Cells(2, 8) = Now
For i = 2 - 1 To uriga1 - 1
    If RP(i, 1) <> "" Then
        For j = 2 - 1 To uriga2 - 1
            If RP(i, 1) = SH(j, 1) Then
                wks2.Cells(j, 1).Interior.ColorIndex = 9
            End If
        Next j
   End If
Next i
wks1.Cells(3, 8) = Now
Set wks1 = Nothing
Set wks2 = Nothing
ftime = Timer
Cells(5, 8) = ftime - itime
Application.ScreenUpdating = True

itime = Timer
Application.ScreenUpdating = False
Set wks1 = ThisWorkbook.Worksheets("Foglio1")
Set wks2 = ThisWorkbook.Worksheets("Tutti2016_2")

Sheets(1).Select
uriga1 = wks1.Range("A" & Rows.Count).End(xlUp).Row
RP = wks1.Range(Cells(2, 1), Cells(uriga1, 1)).Value    ''''

Sheets(2).Select
Range("A:A").Interior.ColorIndex = xlNone
Set Rng = Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
uriga2 = wks2.Range("E" & Rows.Count).End(xlUp).Row
SH = wks2.Range(wks2.Cells(2, 5), wks2.Cells(uriga2, 5)).Value
wks1.Cells(2, 8) = Now
For i = 2 - 1 To uriga1 - 1
    If RP(i, 1) <> "" Then
        For j = 2 - 1 To uriga2 - 1
            If RP(i, 1) = SH(j, 1) Then
                wks2.Cells(j, 1).Interior.ColorIndex = 9
            End If
        Next j
   End If
Next i
wks1.Cells(3, 8) = Now
Set wks1 = Nothing
Set wks2 = Nothing
ftime = Timer
Cells(5, 8) = ftime - itime
Application.ScreenUpdating = True

MsgBox "Fatto!", vbExclamation
End Sub

di Daniela (utente non iscritto) data: 27/12/2017 11:23:23
P.S.

Io i dati nel FOGLIO1, ovvero quelli da cercare, li cambio e aggiorno continuamente, questo non causa problemi giusto? o devono essere ordinati in qualche modo i dati, mi pare di aver letto qualcosa a riguardo all'inizio della discussione...

di Marius44 data: 27/12/2017 15:04:19
Ciao Daniela
Intanto auguri passati e … futuri (abbiamo ancora Capodanno, non ti pare?) e grazie per il riscontro.

Ora veniamo alla tua ultima richiesta.
1 – I dati in Foglio1 possono stare come ti pare. Se devi confrontarli con 10 Fogli è importante che non cambino durante i confronti.
2 – Sì. Puoi concatenare (diciamo meglio ciclare) il confronto in un’unica macro. Prendo la parte di codice interessata dal ciclo:

Set wks1 = ThisWorkbook.Worksheets("Foglio1")
Questa riga la puoi lasciare visto che il Foglio è sempre lo stesso

Set wks2 = ThisWorkbook.Worksheets("Tutti2016_1")
Questa riga, invece, no. Il nome deve cambiare di volta in volta e, pertanto, deve essere inserita “dentro” il ciclo. Vediamo dopo dove inserirla.

Sheets(1).Select
uriga1 = wks1.Range("A" & Rows.Count).End(xlUp).Row
RP = wks1.Range(Cells(2, 1), Cells(uriga1, 1)).Value ''''
Queste tre righe rimangono invariate e possono stare dove sono adesso

Da qui in avanti deve iniziare il ciclo per tutti i Fogli. Per evitare di cambiare il nome del Foglio sarebbe meglio fare così: tutti i Fogli devono stare DOPO il Foglio1 e, quindi, impostare il ciclo da Foglio2 fino al Foglio-ultimo (possono essere anche meno o più di 10). Impostiamo il ciclo per i Fogli:

For fg = 2 to Sheets.Count
Set wks2 = ThisWorkbook.Worksheets(fg) ‘fg è il numero del Foglio
Sheets(fg).Select
Range("A:A").Interior.ColorIndex = xlNone
Set Rng = Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
uriga2 = wks2.Range("E" & Rows.Count).End(xlUp).Row
SH = wks2.Range(wks2.Cells(2, 5), wks2.Cells(uriga2, 5)).Value
‘wks1.Cells(2, 8) = Now ‘questa riga diventa inutile
For i = 2 - 1 To uriga1 - 1
If RP(i, 1) <> "" Then
For j = 2 - 1 To uriga2 - 1
If RP(i, 1) = SH(j, 1) Then
wks2.Cells(j, 1).Interior.ColorIndex = 9
End If
Next j
End If
Next i
Next fg

Ovviamente non ho modo di testarla ma dovrebbe andar bene. Per una decina di fogli impiegherà tutta una notte. Troppo tempo per sapere se funziona. Prova con soli due Fogli cambiando Sheets.Count con 3. Dopo rimetti a posto.

Ti posto sotto la macro intera

Fai sapere. Ciao,
Mario

Sub ColoraCelleUguali()   ‘versione con ciclo per i Fogli
'by Marius44
Dim i As Long, j As Long, uriga1 As Long, uriga2 As Long
Dim wks1 As Worksheet, wks2 As Worksheet
Dim Rng As Range
Dim RP, SH, itime, ftime
itime = Timer
Application.ScreenUpdating = False
Set wks1 = ThisWorkbook.Worksheets("Foglio1")
wks1.Cells(2, 8) = Now                           ‘riga spostata
Sheets(1).Select
uriga1 = wks1.Range("A" & Rows.Count).End(xlUp).Row
RP = wks1.Range(Cells(2, 1), Cells(uriga1, 1)).Value    ''''
‘inizio ciclo per fogli
For fg = 2 to Sheets.Count
    Set wks2 = ThisWorkbook.Worksheets(fg)      ‘fg è il numero del Foglio
    Sheets(fg).Select            
    Range("A:A").Interior.ColorIndex = xlNone
    Set Rng = Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
    uriga2 = wks2.Range("E" & Rows.Count).End(xlUp).Row
    SH = wks2.Range(wks2.Cells(2, 5), wks2.Cells(uriga2, 5)).Value
    For i = 2 - 1 To uriga1 - 1
        If RP(i, 1) <> "" Then
            For j = 2 - 1 To uriga2 - 1
                If RP(i, 1) = SH(j, 1) Then
                    wks2.Cells(j, 1).Interior.ColorIndex = 9
                End If
            Next j
       End If
    Next i
Next fg
wks1.Cells(3, 8) = Now
Set wks1 = Nothing
Set wks2 = Nothing
ftime = Timer
Cells(5, 8) = ftime - itime
Application.ScreenUpdating = True
MsgBox "Fatto!", vbExclamation
End Sub

di Zer0Kelvin data: 27/12/2017 15:35:11
Qualcosa non va decisamente, ma non credo siano le macro.
Ho provato la macrodi Marius44 ed è un pochino più veloce della mia, impiega circa 9,8 secondi a completare i confronti.
Ed il mio PC è quasi una caffettiera
Win 7 ultimate 64 bit
Excel 2010 32 bit
Cpu intel Pentium (Pentium!) G630 a 2,7 GHz
Ram 4GB
Indice prestazioni di Windows 4.3
quindi un vero cesso, però entrambe le macro (la mia e di MArius44), sul file allegato con DropBox girano in una MANCIATA DI SECONDI.
di Daniela (utente non iscritto) data: 27/12/2017 15:59:15
Guarda io penso che dipenda dal fatto che effettivamente nel primo foglio non ci sono matching. nei rimanenti a me impiega una 20ina di minuti per 6.000 celle da confrontare su 600.000 ... prova a estrapolare 6000 celle dal file su cui cercare e metterli come dati nel Foglio1, penso che impiegherà del tempo. Insomma... una manciata di secondi non ce li mette proprio!! ahahahahha
di Zer0Kelvin data: 27/12/2017 19:24:47
Veramente io mi riferivo al file di test, dato che Marius aveva scritto:
Ho notato che ogni 9 valori (cicli) del Foglio1 impiega 1 sec. circa. Visto che ci sono poco più di 27000 righe dovrebbe impiegare poco meno di un'ora.

e quando hai replicato:
Benissimo la macro di Marius44 che effettivamente ha impiegato 1ora e 4 min per il matching!!

ho ritenuto si stesse parlando ancora di quello.
Evidentemente ho interpretato male quello che è stato scritto.
di Daniela (utente non iscritto) data: 28/12/2017 09:08:27
Ciao Marius ho provato la macro con la ripetizione dei cicli stanotte... SEMBRA OK!!!

Grazie a tutti!!

Buona fine 2017 e un ottimo 2018!

A presto
di Marius44 data: 28/12/2017 10:23:43
Ciao Daniela
Grazie per il riscontro e per gli Auguri che contraccambio di vero cuore.

Ciao e ... alla prossima,
Mario

Vuoi Approfondire?

Macro funzionante ma lentissima

Ciao Zer0Kelvin