Ricerca dato doppio

Hai un problema con Excel?

Nuova discussione

Ricerca dato doppio
di nichicanta data: 16/06/2013 21:08:06
Amici del forum, nello storico delle discussioni ho trovato finalmente il codice (del caro Vecchio Frac) che mi trova in un range, dei valori duplicati, inoltre ho aggiunto la macro che mi conta il totale dei dati duplicati ( li ho divisi per 2 poiché il codice di V.F. me li colora di giallo entrambi, quindi voglio sapere solo il nr. singolo delle domande uguali).
Il mio problema è che quando mando in esecuzione il codice di V.Frac. ci mette tanto tempo al punto di farmi necessariamente chiudere il programma e ricominciare, ma con la stessa storia.
Vi chiedo gentilmente di ( poiché è quello che cercavo) di farmi capire perché una volta andato in esecuzione, il codice ci mette moooolto tempo.
Ho cercato con le mie capacità, di poter risolvere ordinando i dati alfabeticamente ( ho creato una macro con il registratore di macro e funziona) per quella colonna, ma senza risultato.
In attesa di un Vostro gradito e prezioso aiuto, Vi saluto.

Sub find_dups()
Dim cella As Range, r As Range
ActiveWorkbook.Worksheets("Foglio1").Select
Range("b1:b6500").Interior.ColorIndex = xlNone
Call ordina_crescente
    Set r = [b1:b6500]
    
    For Each cella In r
        If Trim(cella) <> "" And _
            cella.Interior.ColorIndex <> 6 And _
            count_occurrences(r, (cella)) > 1 Then
            cella.Interior.ColorIndex = 6
        End If
        Next

End Sub

Private Function count_occurrences(r As Range, search As String)

Dim s As String, v As Variant, i As Integer, vect() As String

    ReDim vect(1 To r.Count)
    For Each v In r
        i = i + 1
        vect(i) = v
    Next
    
    s = Join(vect, vbNullChar) & vbNullChar
    s = LCase(s)
    search = LCase(search)
    count_occurrences = Len(Replace(s, search & vbNullChar, _
        search & vbNullChar & "*")) - Len(s)

End Function
Sub Conta_Colorate()
 ActiveWorkbook.Worksheets("Foglio1").Select
    Dim cella
    Dim somma As Integer
    somma = 0
    For Each cella In Range("b1:b6500")
        If cella.Interior.ColorIndex = 6 Then
            somma = somma + 1
        End If
    Next
        If somma = 0 Then
        MsgBox "Non ci sono dati duplicati"
        Else
        MsgBox "Ho trovato " & somma / 2 & " dati duplicati."
        End If

End Sub

di Textomb data: 17/06/2013 20:11:53
il codice potrebbe essere un pò lungo perchè scorre 6500 celle e lo fa un paio di volte.
Anche se in teoria non dovrebbe metterci molto tempo. Tranne che hai allargato il range.
Se vuoi ottimizzare la performance, dovresti provare, nella sub Conta_Colorate(), al posto di For each cella... di utilizzare un ciclo Do... Loop con il metodo Find e searchFormat = True. In questo modo non scorre più 6500 celle ma va direttamente e solo nelle celle colorate. Così risparmi un bel pò di tempo...
Spero di essere stato chiaro.
di nichicanta (utente non iscritto) data: 17/06/2013 21:11:34
Carissimo Textomb, piacere di fare la tua conoscenza.
Il problema non mi si presenta nella funzione conta_colorate (l'ho disabilitata) bensì nella partenza del codice di Vecchio Frac, non riesco a capire il perché. Dimmi solo se il codice di V.F. va bene per evidenziare i duplicati e mi impegnerò con tutte le mie forze e conoscenze ad effettuare la ricerca dei dati doppi ( con altra funzione)attenendomi alle indicazioni da te segnalate.

di Vecchio Frac data: 17/06/2013 21:16:10
E' stra-lento perchè la function "count_occurrences" utilizzata così, in un ciclo di ben seimilacinquecento celle, deve ricalcolarsi ogni volta, ad ogni passaggio dopo Next, l'intero vettore di valori per stabilire se ve ne siano di duplicati...
Facciamo una cosa furba: poichè è stabilito il range, costruiamo il vettore di valori e utilizziamo sempre quello per il conteggio, visto che nel ciclo For non cambia.
Dovrebbe essere molto più rapido... fai qualche test.
Anzi, se "conteggio" la dichiari as public in testa al modulo (dopo option explicit) potresti anche sfruttarla per avere subito il conteggio dei duplicati con cella gialla (evitando di scrivere tutta la routine "conta_colorate").

option explicit

Sub find_dups()
Dim cella As Range, r As Range
Dim s As String, v As Variant, i As Integer, vect() As String
Dim search as String, conteggio as Long

    ActiveWorkbook.Worksheets("Foglio1").Select
    Range("b1:b6500").Interior.ColorIndex = xlNone
    Call ordina_crescente
    
    Set r = [b1:b6500]
   
    ReDim vect(1 To r.Count)
    For Each v In r
        i = i + 1
        vect(i) = v
    Next
    
    s = Join(vect, vbNullChar) & vbNullChar
    s = LCase(s)

    For Each cella In r
        search = LCase(cella)
        conteggio = Len(Replace(s, search & vbNullChar, _
        search & vbNullChar & "*")) - Len(s)
        If Trim(cella) <> "" And _
            cella.Interior.ColorIndex <> 6 And _
            conteggio > 1 Then
            cella.Interior.ColorIndex = 6
        End If
   Next

End Sub



Sub Conta_Colorate()
 ActiveWorkbook.Worksheets("Foglio1").Select
    Dim cella
    Dim somma As Integer
    somma = 0
    For Each cella In Range("b1:b6500")
        If cella.Interior.ColorIndex = 6 Then
            somma = somma + 1
        End If
    Next
        If somma = 0 Then
        MsgBox "Non ci sono dati duplicati"
        Else
        MsgBox "Ho trovato " & somma / 2 & " dati duplicati."
        End If
End Sub

di Vecchio Frac data: 17/06/2013 21:16:46
ops, mentre scrivevo non mi ero accorto dell'intervento di nichi... scusate ^_^

di Textomb data: 18/06/2013 00:24:10
ho provato a rivedere un pò il tutto. Ma solo per sfizio.
poi ho fatto delle prove e questo qui sotto gira, sul mio pc, con un decimo di secondo in meno...
provate. provate.
Chissà se si può fare ancora più veloce e con meno codice.

Sub Find_Dups2()
Dim cella As Range, R As Range, NoDups As New Collection, Dups As New Collection, s As Variant
Dim Somma As Integer
    ActiveWorkbook.Worksheets("Foglio8").Select
    Range("b1:b6500").Interior.ColorIndex = xlNone
    [b1:b6500].Sort key1:=[b1], Header:=xlNo

Set R = [b1:b6500]
On Error Resume Next
For Each cella In R
NoDups.Add Item:=cella, Key:=CStr(cella)
    If Err.Number <> 0 Then
    Dups.Add Item:=cella
    Err.Number = 0
    End If
Next

Set cella = [b1]
For Each s In Dups
    Do
    Set cella = R.Find(what:=s, lookat:=xlWhole)
    If cella.Interior.ColorIndex = 6 Then Exit Do
    Set R = Range("B" & cella.Row & ":B6500")
    cella.Interior.ColorIndex = 6
    Somma = Somma + 1
    Loop
Next

MsgBox "Ho trovato tot " & Somma / 2 & " celle colorate"

End Sub

di nichicanta (utente non iscritto) data: 18/06/2013 13:36:50
Di certo più veloce l'esecuzione del codice, ma ho riscontrato un problema.
Nel range dove effettua il controllo del dato doppio (qualora le celle sono vuote, non contengono dati) vengono colorate lo stesso di giallo ( è come se le considerasse dato doppio).
In relatà il range da me indicato è fittizio, cioè io vorrei eseguire il controllo del dato doppio in quella colonna (avevo indicato il range per accorciare il tempo del codice, in base ad una quantità di dati minori, che su colonna intera).
Ripeilogando,il codice dovrebbe effettuare il controllo del dato doppio nella colonna b (ed evidenziare di giallo le celle che contengono i dati e solo quelli duplicati, non le celle senza dati).
Mi auguro di essere stato chiaro.
Grazie Textomb per il tuo interessamento, ti chiedo, per favore di risolvere la problematica, dato che ci siamo quasi, è quello che desidero ottenere.
di Textomb data: 18/06/2013 15:44:24
non ho capito se ti riferisci a quello che ho postato io oppure il grande VF.
In ogni caso, per quanto riguarda il codice riveduto da me, dovrebbe funzionare se sostituisci la riga seguente
If Err.Number <> 0 Then
con questa
If Err.Number <> 0 And cella <> "" Then
Fammi sapere.
ciao
di nichicanta (utente non iscritto) data: 18/06/2013 16:34:11
Ok Textomb, va benissimo, testato è quello che cercavo.
Un ringraziamento particolare (oltre che a te) anche a V. F. sempre disponibile e risolutivo.

Vuoi Approfondire?