Ciao scossa, le tue osservazioni hanno sempre un fondamento...
In effetti non ha senso fare ambedue i controlli se gia' il primo risultasse negativo, quindi ho adottato la tua filtra2.
Con stupore ho visto che il tempo tra filtra e filtra2 si riduce di pochi centesimi di secondo, misurato su un totale di 5 prove per un totale di oltre 100 secondi.
Anche elaborando in modo diverso la ricerca (tipo invertire i controlli e skippare se esito negativo) le differenze rimangono dell'ordine max di 2 decimi su circa 104 secondi, cioe' dell'ordine dello 0,2%.
Questo dimostra, ma lo dovevamo sapere, che i tempi maggiori sono consumati per scrivere sul secondo foglio...
Ho quindi elaborato una filtra33 che usa un array da 10mila posizioni per accumulare la colonna filtrata, con successivo dump dei risultati sul foglio target all'esaurimento dello spazio.
In questo modo, i cicli che prima duravano circa 20 sec ora si completano in 0,3 Sec.
Il codice corrispondente, che sostituisce interamente la Sub filtra:
- Codice: Seleziona tutto
Sub filtra33()
Dim OutSh As String, StrSh As String, YesStr, NoStr, LastA As Long, j As Long, myTim As Double
Dim I As Long, cFound As Long, CRowV As String, YesOk As Boolean, NoNOk As Boolean
Dim NextOut As Long, OuArr(1 To 10000) As String
'
OutSh = "FoglioZ" '<<< Il foglio dove si crea l'elenco filtrato
YesStr = Array("Y1", "YC1", "YM1")
NoStr = Array("YY", "DY", "CY", "EY", "AY", "RY", "OY")
LastA = Cells(Rows.Count, 1).End(xlUp).Row
myTim = Timer
Sheets(OutSh).Range("A:A").ClearContents
For I = 2 To LastA
YesOk = False: NoNOk = False
CRowV = Cells(I, 1).Value
For j = LBound(YesStr, 1) To UBound(YesStr, 1)
cFound = InStr(1, CRowV, YesStr(j), vbTextCompare)
If cFound > 0 Then YesOk = True: Exit For
Next j
If YesOk Then
For j = LBound(NoStr, 1) To UBound(NoStr, 1)
cFound = InStr(1, CRowV, NoStr(j), vbTextCompare)
If cFound > 0 Then NoNOk = True: Exit For
Next j
If YesOk And Not NoNOk Then
NextOut = NextOut + 1
OuArr(NextOut) = Cells(I, 1)
If NextOut >= 10000 Then
Sheets(OutSh).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(NextOut, 1).Value = OuArr
NextOut = 0
End If
End If
End If
Next I
If NextOut > 0 Then
Sheets(OutSh).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(NextOut, 1).Value = OuArr
NextOut = 0
End If
MsgBox ("Completato, Sec. " & Format(Timer - myTim, "0.00"))
End Sub
Le N macro, compresa la filtra33, sono contenute nel file che ho salvato qui:
https://www.dropbox.com/s/725y8geigs2d2 ... .xlsm?dl=0Ps: non ho capito che macchina ha mirmidone per completare il lavoro di 19mila righe in 0.13 secondi; wow...
Ciao a tutti.