Cercare un numero in diverse colonne contemporaneamente.

[ikwae]

Ciao a tutti, sono qui ancora a chiedere il vostro prezioso aiuto.
Ho scritto una macro, che cerca un numero in diverse colonne contemporaneamente, ma è relativamente “veloce” o accettabile se le righe sono meno di 100 mila. Purtroppo a me serve che legga fino a milione di righe e oltre. Per adesso mi limito a poco meno di 1 milione e man mano che le estrazioni aumentano(si parla di 2.555.190 quartine del Lotto) vedrò sul da farsi eventualmente aprirò un nuovo post di aiuto al Forum. Allego la macro che cerca contemporaneamente nelle colonne C:F(end) e trovato il numero riporta i numeri della stessa riga ,compreso il valore che è sulla colonna G, accodandoli in colonna X partendo da X2. Quindi cerco nel range C3:F(end) il numero riportato in P3 e quando
lo trovo riporto la quartina accodandola partendo da X2. Aggiungo che il numero da cercare non deve essere riportato in colonna X. Faccio un esempio... il numero in P3 è 33 quindi cerco nel range C3:F(end) il numero 33 e trovo la prima quartina 81 54 33 55 con valore (in blu) 5 quindi riporto in colonna X solo i numeri 81 54 55 5. La seconda quartina che si trova è 46 76 33 20 con valore 5 quindi è da accodare in colonna X solo i numeri 46 76 20 5. Penso che leggendo la macro si capisca cosa cerco tuttavia è meglio dare qualche descrizione con esempio in più per non far perdere tempo a chi eventualmente mi vuole aiutare. Se la mia macro non si riesce modificare per renderla veloce e se ne propone un’altra con le stesse caratteristiche sarà molto gradita. Allego anche un file per eventuale prove.
Ringraziando anticipatamente tutti colore che mi aiuteranno. 73 ikwae

Codice: Seleziona tutto

Sub Cerca_Numero_In_4Col()
Dim CL As Range, zona As Range
Dim T As Single
Dim r As Integer

Application.ScreenUpdating = False
T = Timer
    Set zona = Sheets("Sviluppo").Range("C3", "F3:F" & [F3].End(xlDown).Row) '

For Each CL In zona
             
   If CL.Value = Range("P3").Value Then 'il valore di P3
    CL.Select
   If ActiveCell = Cells(ActiveCell.Row, 3) Then GoTo 10 'col C
   If ActiveCell = Cells(ActiveCell.Row, 4) Then GoTo 20 'col D
   If ActiveCell = Cells(ActiveCell.Row, 5) Then GoTo 30 'col E
   If ActiveCell = Cells(ActiveCell.Row, 6) Then GoTo 40 'col F
   '
   Else: GoTo 50
 
10 '--COLONNA--C--
r = Sheets("Sviluppo").Cells(Rows.Count, 24).End(xlUp).Row + 1
ActiveCell.Range("B1:E1").Copy Sheets("Sviluppo").Cells(r, 24)
GoTo 50

20 '--COLONNA--D--
r = Sheets("Sviluppo").Cells(Rows.Count, 24).End(xlUp).Row + 1
ActiveCell.Offset(0, -1).Range("A1, C1:E1").Copy Sheets("Sviluppo").Cells(r, 24)
GoTo 50

30 '--COLONNA--E--
r = Sheets("Sviluppo").Cells(Rows.Count, 24).End(xlUp).Row + 1
ActiveCell.Offset(0, -2).Range("A1,B1, D1:E1").Copy Sheets("Sviluppo").Cells(r, 24)
GoTo 50

40 '--COLONNA--F--
r = Sheets("Sviluppo").Cells(Rows.Count, 24).End(xlUp).Row + 1
ActiveCell.Offset(0, -3).Range("A1:C1,E1").Copy Sheets("Sviluppo").Cells(r, 24)
GoTo 50

50
End If
Next
Application.CutCopyMode = False
Range("W1").Select
Set zona = Nothing
Application.ScreenUpdating = True
MsgBox "Completato in (sec): " & Format(Timer - T, "0.00"), vbInformation

End Sub
 

https://www.dropbox.com/s/e8y6w83jdb3wd ... 4.zip?dl=0

[Anthony47]

Questa?

Codice: Seleziona tutto

Sub Cerca4C()
Dim wArr, oArr(), lastC, I As Long, J As Long
Dim lFor As Integer, kO As Long, kV As Long, kJ As Long
'
myTim = Timer
lastC = Cells(Rows.Count, 3).End(xlUp).Row
'lastC = 200000
wArr = Range("C3:G" & lastC).Value
lFor = Range("P3").Value
J = Application.WorksheetFunction.CountIf(Range("C3:G" & lastC), lFor)
ReDim oArr(1 To J, 1 To 4)
For I = LBound(wArr) To UBound(wArr)
    For J = 1 To 4
        If wArr(I, J) = lFor Then
            kO = kO + 1: kJ = 0
                For kV = 1 To 5
                    If kV <> J Then
                        kJ = kJ + 1
                        oArr(kO, kJ) = wArr(I, kV)
                    End If
                Next kV
            Exit For
            End If
    Next J
Next I
Range("X:AA").ClearContents
Range("X2").Resize(UBound(oArr, 1), 4) = oArr
MsgBox ("Completato, Sec: " & Format(Timer - myTim, "0.00"))
End Sub


I dati saranno trascritti partendo da X2; le colonne X:AA saranno AZZERATE completamente prima di riscrivere il nuovo contenuto.

Ciao

[ikwae]

Gentilissimo Anthony ... ho scaricato prima la macro per dare un’unica risposta quindi è velocissima come un “siluro”
anzi di più e sul Pentium4 impiega 10,8 secondi mentre sul pc che uso normalmente il risultato è istantaneo ...
io non avevo dubbi che i calcoli sono giusti lo scrivo come naturale riscontro per il lavoro che hai fatto e per altre persone che leggono il post. Quindi sono a posto e super felice tuttavia mi è venuto in mente che posso sfruttare le macro dei terni, che mi hai aiutato a scrivere in un’altro post di aiuto, fintanto che apro un’altro post di aiuto per le macro che servono per ulteriori sviluppi sulle quaterne.
Quindi ti chiedo, se possibile e, hai ancora del tuo prezioso tempo da dedicarmi di modificare la macro affinché legga due numeri anziché uno solo. Inutile dire che ho “letto” la tua macro che per me e arabo scritto in cinese. Quindi ti pregherei di modificare la macro affinché trovi due numeri anziché uno solo. I numeri da ricercare sono in P3 e Q3 accodando, i numeri rimanti(due più il valore ossia tre numeri) sulla stessa riga, in X2.
Ringraziandoti della tua gentilezza e generosa disponibilità che mi hai dedicato che sono state da me molto gradite. Cordialmente ikwae

[Anthony47]

Questa versione e' leggermente piu' lenta della precedente ma puo' cercare sia 2 numeri (P3-Q3) che 1 solo numero (P3; Q3=vuoto)
L'output e' sempre su 4 colonne, eventualmente la 4° sara' vuota.

Codice: Seleziona tutto

Sub Cerca4Cx2()
Dim wArr, oArr(), lastC, I As Long, J As Long
Dim lFor As Integer, kO As Long, kV As Long, kJ As Long
Dim lDue As Integer, matCnt As Integer
'
mytim = Timer
lastC = Cells(Rows.Count, 3).End(xlUp).Row
'lastC = 200000
wArr = Range("C3:G" & lastC).Value
lFor = Range("P3").Value
lDue = Range("Q3").Value
J = Application.WorksheetFunction.CountIf(Range("C3:G" & lastC), lFor)
ReDim oArr(1 To J, 1 To 4)
For I = LBound(wArr) To UBound(wArr)
'If I > 6230 Then Stop           '6236
    If lDue > 0 Then matCnt = 0 Else matCnt = 1
    For J = 1 To 4
        If wArr(I, J) = lFor Or wArr(I, J) = lDue Then
            matCnt = matCnt + 1
        End If
        If matCnt = 2 Then
            kO = kO + 1: kJ = 0
                For kV = 1 To 5
                    If wArr(I, kV) <> lFor And wArr(I, kV) <> lDue Then
                        kJ = kJ + 1
                        oArr(kO, kJ) = wArr(I, kV)
                    End If
                Next kV
            Exit For
        End If
    Next J
Next I
Range("X:AA").ClearContents
Range("X2").Resize(UBound(oArr, 1), 4) = oArr
MsgBox ("Completato, Sec: " & Format(Timer - mytim, "0.00"))
End Sub

Ciao

[ikwae]

Gentilissimo Anthony, che dire è uno spettacolo è leggermente più lenta come dici te ma di ‘naticchia (si legge nanticchia in siculo vuol dire pochissimo anche se non sono siciliano questa parola la uso moltissimo nel quotidiano) quasi inavvertibile quindi super perfetta che mi consente di andare avanti fintanto non preparo la nuova macro per formare le cinquine con le quaterne. Apprezzo molto il “doppio” lavoro che ti ho chiesto che dire RINNOVO la spaghettata per te e il tuo Team del Forum oltre mille grazie per il tuo tempo che mi hai dedicato. Cordialmente ikwae