macro per copiare un elenco senza doppioni

[Ale75]

Salve,

ho realizzato una macro con l'idea di scorrere un elenco (ad esempio nella colonna A del primo Foglio) e copiare lo stesso elenco nella seconda pagina ma senza doppioni. inoltre vorrei copiare anche i doppioni indicando il rigo (del primo foglio) dove sono stati trovati

Codice: Seleziona tutto

Sub trovadoppioni()

Dim Cella As Range
Dim Intervallo, Origine, Desinazione As Range

Set Origine = Sheets("Sheet1")
Set Destinazione = Sheets("TagList")
Set Intervallo = Origine.Range("A3:A20")  '-- qui la sorgente di dati

Y = 3
X = 3

For Each Cella In Intervallo

 If WorksheetFunction.CountIf(Range("A3:A" & Cella.Row), Cella) = 1 Then
        Origine.Cells(Cella.Row, 1).Copy   
        Destinazione.Cells(Y, 3).PasteSpecial
        Y = Y + 1
       
    ElseIf Origine.Cells(Cella.Row, 1).Value <> " " Then
                Origine.Cells(Cella.Row, 1).Copy
                Destinazione.Cells(X, 5).PasteSpecial
                Destinazione.Cells(X, 6) = Cella.Row
                X = X + 1
    End If
Next Cella
End Sub


formalmente mi sembra corretta, però non va.
il probrelma sembra essere qui

Codice: Seleziona tutto

        Origine.Cells(Cella.Row, 1).Copy

, nel senso che sembra che non copia il valore della cella
sapete dirmi dove sbaglio?

grazie,
Ale

[Anthony47]

Prova con questa variante:

Codice: Seleziona tutto

For Each Cella In Intervallo
    If WorksheetFunction.CountIf(Origine.Range("A3:A" & Cella.Row), Cella) = 1 Then
        Cella.Copy
        Destinazione.Cells(Y, 3).PasteSpecial
        Y = Y + 1
       
    ElseIf Origine.Cells(Cella.Row, 1).Value <> " " Then
        Cella.Copy
        Destinazione.Cells(X, 5).PasteSpecial
        myMatch = Application.Match(Cella.Value, Intervallo, False)
        Destinazione.Cells(X, 6) = myMatch
        X = X + 1
    End If
Next Cella


Se funziona guarda le differenze, credo che il significato sia intuitivo (comunque siamo qui)

[Ale75]

perfetto !

cosi funziona, ma la parte del match mi sono accorto di aver fatto un errore "concettuale".
cioe se un campo è ripetuto 3 volte il match riscrive il tag duplicato 2 volte ma come riferimento della linea da sempre il rigo corrispondente al primo campo dove ha trovato il valore (diciamo l'originale)

come posso fare per far evidenziare tutte le righe duplicate? cioè avere nella lista dei tag duplicati tutti e tre i valori con le rispettive righe, in modo che poi l'operatore vada a vedere le anomalie

grazie ancora,
Ale

[Anthony47]

Ma allora usa la colonna 6 di Destinazione per scriverci le righe dove compaiono quei valori:

Codice: Seleziona tutto

    For Each Cella In Intervallo
        If WorksheetFunction.CountIf(Origine.Range("A3:A" & Cella.Row), Cella) = 1 Then
            Cella.Copy
            Destinazione.Cells(Y, 3).PasteSpecial
            Destinazione.Cells(Y, 6).Value = Cella.Row            ‘<<< VEDI NOTA
            Y = Y + 1
           
        ElseIf Origine.Cells(Cella.Row, 1).Value <> " " Then
            myMatch = Application.Match(Cella.Value, Destinazione.Ramge("C3:C" & Y), False)
            Destinazione.Cells(myMatch, 6).Value = Destinazione.Cells(myMatch, 6) & " > " & Cella.Row
        End If
    Next Cella


Questa crea l’elenco in colonna 3 come prima ma mette in colonna 6 il numero di riga su cui quel valore compare; dove ci sono piu’ occorrenze in colonna 6 ci saranno piu’ numeri di riga, tipo 28 > 55 > 99

Se in colonna 6 non vuoi scrivere la prima occorrenza (che a me sembra invece utile in fase di debug) allora elimina l’istruzione marcata <<<

[Ale75]

grazie,

ho fatto due sole modifiche
la prima grafica perche c'era un raMge (con la M), la seconda ho aggiuno un "+2" al

Codice: Seleziona tutto

Destinazione.Cells(myMatch + 2, 6).Value = Destinazione.Cells(myMatch + 2, 6) ...


perche inizio a scivere al rigo 2 sul file di destinazione

il codice è questo, funziona ma da errore in fondo

cioè scorre la lista, scrive le righe pero poi da Runtime-error 13, come se all'ultimo ciclo mancasse qualcosa (però la lsita prodotta e corretta e non manca niente

Codice: Seleziona tutto

   
For Each Cella In Intervallo
        If WorksheetFunction.CountIf(Origine.Range("A3:A" & Cella.Row), Cella) = 1 Then
            Cella.Copy
            Destinazione.Cells(Y, 3).PasteSpecial
            Destinazione.Cells(Y, 6).Value = Cella.Row
            Y = Y + 1
           
        ElseIf Origine.Cells(Cella.Row, 1).Value <> " " Then
            myMatch = Application.Match(Cella.Value, Destinazione.Range("C3:C" & Y), False)
            Destinazione.Cells(myMatch + 2, 6).Value = Destinazione.Cells(myMatch + 2, 6) & " > " & Cella.Row     ' <<< problema all'ultimo ciclo
        End If
    Next Cella


[Anthony47]

scrive le righe pero poi da Runtime-error 13, come se all'ultimo ciclo mancasse qualcosa (però la lsita prodotta e corretta e non manca niente

C'e' qualcosa di particolare in Origine.A20? Tipo un "errore"

Perche' nell' ElseIf c'e' il controllo che Value <> " " ?

Forse sarebbe meglio controllare che Cella non sia vuota prima di procedere con If WorksheetFunction.CountIf; tipo:

Codice: Seleziona tutto

For Each Cella In Intervallo
    If Cella.Value <> "" Then                                                 'NUOVO IF /END IF
        If WorksheetFunction.CountIf(Origine.Range("A3:A" & Cella.Row), Cella) = 1 Then
           'etc
           'etc
        End If
    End If
Next Cella

Come pure puo' essere prudente inserire la riga che ora va in errore in un ulteriore if:

Codice: Seleziona tutto

        ElseIf Origine.Cells(Cella.Row, 1).Value <> " " Then
            myMatch = Application.Match(Cella.Value, Destinazione.Range("C3:C" & Y), False)
            If Not IsError(myMatch) Then                           'ulteriore IF /END IF
                Destinazione.Cells(myMatch, 6).Value = Destinazione.Cells(myMatch, 6) & " > " & Cella.Row
            End If
        End If


Ciao

[Ale75]

ho optato per la soluzione piu prudenet.

un ultima cosa.
volevo rendere dinamico l'intervallo nonsapendo quante ighe mettere ed ho modificato cosi

Codice: Seleziona tutto

Set Intervallo = Origine.Range("A3:" & ActiveSheet.Range("a3").End(xlDown).Address)


però è veramnete lento.. dov'è l'errore?
mi sembra lo stesso codice di sempre..

grazie ancora

[Anthony47]

Prova con

Codice: Seleziona tutto

Set Intervallo = Origine.Range("A3:" & Origine.Range("a10000").End(xlUp).Address)

[Ale75]

questa è bella... ho sistemato la macro, è andata bene, ma solo la PRIMA VOLTA.
poi si ferma dopo 3 righe. Uso la stessa macro per fare un alto check ed anche quella si ferma dopo 4 righe...

sono nel buio piu totale..

Codice: Seleziona tutto

Sub TrovaDoppioni_LoadList()

Dim Cella As Range
Dim Intervallo, Origine, Desinazione As Range


Set Origine = Sheets("Sheet 1")
Set Destinazione = Sheets("Sheet 2")
Set Intervallo = Origine.Range("a3:" & ActiveSheet.Range("a10000").End(xlUp).Address)

Y = 4


    For Each Cella In Intervallo
        If WorksheetFunction.CountIf(Origine.Range("a3:a" & Cella.Row), Cella) = 1 Then
            Cella.Copy
            Destinazione.Cells(Y, 3).PasteSpecial
            Destinazione.Cells(Y, 5).Value = Cella.Row
            Y = Y + 1
           
        ElseIf Origine.Cells(Cella.Row, 8).Value <> " " Then
                myMatch = Application.Match(Cella.Value, Destinazione.Range("C3:C" & Y), False)
                If Not IsError(myMatch) Then
                    Destinazione.Cells(myMatch + 2, 5).Value = Destinazione.Cells(myMatch + 2, 5) & " > " & Cella.Row
                End If
                   
        End If
    Next Cella

End Sub


non vedo errori nel codice.. da cosa puoi dipendere?

grazie,
Ale

[Ale75]

errata

Codice: Seleziona tutto

ElseIf Origine.Cells(Cella.Row, 8).Value <> " " Then


corrige

Codice: Seleziona tutto

ElseIf Origine.Cells(Cella.Row, 1).Value <> " " Then


(la condizione di verifica è sempre la colonna 1

scusate la svista

[Anthony47]

Bravo (anche se hai fatto e disfatto da solo )

Io continuo a chiedermi perche' testi Value <> " " Then; vuol dire che le celle vuote sono sempre popolate con "spazio"?

[Ale75]

in realta non ho risolto. continua a non andare, come se quando imposto l'intervallo facesse un errore (per me inspiegabile)

Codice: Seleziona tutto

Set Intervallo = Origine.Range("a3:" & ActiveSheet.Range("a10000").End(xlUp).Address)


ho provato a dare un intervallo fisso (H3:H10000) e funziona.

venendo alla tua domanda

Io continuo a chiedermi perche' testi Value <> " " Then; vuol dire che le celle vuote sono sempre popolate con "spazio"?

no in realtà no, voglio solo indicare una cella vuota foser il comando piu corretto è Value <> "" (senza spazio)

[Anthony47]

Prova con

Codice: Seleziona tutto

    Set Intervallo = Origine.Range("A3:" & Origine.Range("a10000").End(xlUp).Address)

Avevi provato?

E Sì, devi testare <>""

[Ale75]

si avevo provato. ma stranamente a volte va, poi si pianta alla 4a riga.
di fatto va ma solo se imposto l'intervallo fisso.



per il secondo punto ok. ho tolto lo spazio.

[Anthony47]

Hai delle righe vuote all'interno dell'intervallo?
Che significa "si pianta alla 4° riga"? Va in errore, la macro termina e non processa le righe successive, rimane impiccata, ...

Come ultima prova:

Codice: Seleziona tutto

Set Intervallo = Range(Origine.Range("a3"), Origine.Range("a10000").End(xlUp))


[Ale75]

cosi funziona. grazie

con "si pianta" intendo che non va oltre la 4 riga (non ci sono anomalie nel file in uso, ne righe vuote), ma alcune volte scorre tutte le righe altre voltre non va piu della 4.

usero il codice sopra.
grazie.