Eliminazione duplicati

[planera63Partecipante planera63]

Aldo Ercolini ha scritto:

Ti allego due versioni:

Ciao. 

Se può rendere più veloce la routine, visto che a me non serve la copia di tutti i duplicati per fare delle verifiche, nel foglio DatiDuplicati puoi copiare solo la prima riga duplicata riferita ai dati acquisiti in quella data per quella stazione.

 

[Aldo ErcoliniPartecipante Aldo Ercolini Karma: 19 pts]

Prova questa versione e dimmi quanto ci mette.

Se e' un tempo decente ci provo a mettere la progress bar.

Allegati:

You must be logged in to view attached files.

[planera63Partecipante planera63]

Aldo Ercolini ha scritto:

Prova questa versione e dimmi quanto ci mette.

Allora l'ho provata con tutti i dati e subito si blocca segnalando questo errore:

Errore run-time '424': Necessario oggetto.

Eseguendo il Debug, evidenzia in giallo la riga 32 del codice

Sheets (SH2).Range...Copy.PasteSpecial ()

[Aldo ErcoliniPartecipante Aldo Ercolini Karma: 19 pts]

Corretto.

Allegati:

You must be logged in to view attached files.

[planera63Partecipante planera63]

Aldo Ercolini ha scritto:

Corretto.

[planera63Partecipante planera63]

Aldo Ercolini ha scritto:

Corretto.

Per ora il portatile Lenovo, con i7, 32Gb di RAM, e office a 64bit sta lavorando da 100 minuti e non ha finito. 

Se si velocizza, come ti ho detto, puoi copiare solo la prima riga per ogni campagna di quella stazione e per quella data in cui sono presenti duplicati 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Raffaele53 ha scritto:

mi spieghi come avviare una Function

La Function funziona come una normale subroutine con la differenza che restituisce un valore di ritorno. Se c'e' un parametro da fornire alla Function, questa va richiamata fornendo il parametro richiesto. La Function - dal momento che restituisce un valore - puo' essere assegnata a una variabile, ed e' quella la sua funzione principale: elaborare un risultato e restituirlo.

La Function quindi non si "avvia" come una Sub  ma si assegna con un'espressione: myvar = myFunction(param).

In Excel: se prendi una Function, la rendi Public e la infili in un modulo, puo' essere trattata come una formula ed essere richiamata direttamente in Excel: A2:  =myFunction(param). In questo caso prende il nome di UDF, User Defined Function e restituisce il risultato direttamente in cella. In questa forma ci sono alcune limitazioni (non si possono modificare direttamente i valori di altre celle per esempio).

 

[scossaPartecipante scossa Karma: 37 pts]

Questo codice impiega, sul file che hai allegato al post#1, circa 10 secondi a scrivere in Foglio2, eliminarle e mostrare nella statusbar la progressione, le 715 righe duplicate; se non aggiorni la statusbar impiega circa 5 secondi.

Se non le scrivi ci impiegherebbe meno di 1 secondo.

Quindi il tempo maggiore lo impiega a copiare le righe prima di eliminarle e mostrare la progressione.

N.B.: aggiungi un foglio in cui copierai la riga 1 delle intestazioni e sostituisci Foglio2 nell'istruzione Set wsTo = Foglio2 con il codename del foglio che aggiungi (il codename dovrebbe corrispondere al testo mostrato nel tab del foglio ma verifica).

Sub RemoveTwins()
  'by scossa
  'https://www.excelvba.it/forumexcel/forums/discussione/eliminazione-duplicati/
  
  Dim ws As Worksheet, wsTo As Worksheet
  Dim rngFr As Range
  Dim rCell As Range, rRow As Range
  Dim sKey As String, sItem As String, aRow As Variant
  Dim nRowDup As Long, j As Long
  Dim cValid As Collection, cDup As Collection

  Set cValid = New Collection
  Set cDup = New Collection
  Set ws = Foglio1
  Set rngFr = ws.UsedRange
  Set rngFr = Intersect(rngFr, rngFr.Range("H:O"))
  Set wsTo = Foglio2
  
  wsTo.UsedRange.Offset(1).ClearContents
  
  On Error Resume Next
  For Each rRow In rngFr.Rows
    aRow = rRow.Value
    With Application
      aRow = .Transpose(.Transpose(aRow))
    End With
    sKey = Join(aRow, "§")
    sItem = rRow.Offset(0, -7).Cells(1, 1).Value
    cValid.Add sItem, sKey
    If Err.Number Then cDup.Add rRow.Row
    Err.Clear
  Next rRow
  On Error GoTo 0
  With Application
    .ScreenUpdating = False
    j = 1
    For nRowDup = cDup.Count To 1 Step -1
      aRow = cDup.Item(nRowDup)
      With ws.Rows(aRow).EntireRow
        j = j + 1
        '.Copy wsTo.Rows(j)
        .Delete
      End With
      '.StatusBar = "riga " & aRow & " eliminata"
    Next
    .StatusBar = False
    .ScreenUpdating = True
  End With
  MsgBox "eliminate " & cDup.Count & " righe"
  Set cValid = Nothing
  Set cDup = Nothing
  Set rngFr = Nothing
  Set wsTo = Nothing
  Set ws = Nothing
  
End Sub

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

@vecchio frac
Più o meno lo sapevo già, la mia domanda era (vista la Tua Function...) cosa devo fare per provarla ???

@planera63
Portatile Intel(R) Core(TM) i3-3110M CPU @ 2.40GHz - 12 Ram
600.000 record. Eliminato doppioni in meno di un minuto

Sub Duplicati_3()
Dim Ur As Long
Ur = Range("A" & Rows.Count).End(xlUp).Row
    Columns("A:V").Range("$A$1:$V$" & Ur).RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6 _
        , 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22), Header:=xlYes
MsgBox "Fatto"
End Sub

[planera63Partecipante planera63]

scossa ha scritto:

Questo codice impiega, sul file che hai allegato al post#1, circa 10 secondi a scrivere in Foglio2, eliminarle e mostrare nella statusbar la progressione, le 715 righe duplicate; se non aggiorni la statusbar impiega circa 5 secondi.

Se voglio eliminare la status bar, quale parte del codice devo disattivare? 

Volendo ridurre ancora di più il tempo di esecuzione, potresti scrivermi per piacere anche il codice che copia una sola riga dei duplicati di quella stazione per quella data ? I duplicati quando ci sono, sono presenti in tutti i dati acquisti in una determinata data e per una determinata stazione.

 

Spero di essermi fatto capire.

Grazie mille 

[OscarPartecipante Oscar Karma: 45 pts]

Rudimentale , ma una frazione di secondo elimina 715 duplicati

[planera63Partecipante planera63]

Raffaele53 ha scritto:

@vecchio frac Più o meno lo sapevo già, la mia domanda era (vista la Tua Function...) cosa devo fare per provarla ???

Potresti scrivermi per piacere anche il codice che copia anche una sola riga dei duplicati di quella stazione per quella data in un altro foglio (Foglio2) ? I duplicati quando ci sono, sono presenti in tutti i dati acquisti in una determinata data e per una determinata stazione.

[planera63Partecipante planera63]

Oscar ha scritto:

Rudimentale , ma una frazione di secondo elimina 715 duplicati

Potresti scrivermi per piacere anche il codice che copia anche una sola riga dei duplicati di quella stazione per quella data in un altro foglio (Foglio2) ? I duplicati quando ci sono, sono presenti in tutti i dati acquisti in una determinata data e per una determinata stazione.

[OscarPartecipante Oscar Karma: 45 pts]

planera63 ha scritto:

Potresti scrivermi per piacere anche il codice che copia anche una sola riga dei duplicati di quella stazione per quella data in un altro foglio (Foglio2) ? I duplicati quando ci sono, sono presenti in tutti i dati acquisti in una determinata data e per una determinata stazione.

Devi allegare un esempio con la data e spiegare cosa devi fare  io non l'ho spostata su un'altro foglio il mio è solo un esempio , ma meglio utilizzare un foglio Temp per non avere problemi

[scossaPartecipante scossa Karma: 37 pts]

Oscar ha scritto:

udimentale , ma una frazione di secondo elimina 715 duplicati

Ma così sfalsi il campo ID e non credo che sia una bella cosa (di solito è un campo chiave).

P.S.: hai un pc potente, sul mio pc vecchiotto impiega circa 9 secondi.

[scossaPartecipante scossa Karma: 37 pts]

planera63 ha scritto:

Volendo ridurre ancora di più il tempo di esecuzione, potresti scrivermi per piacere anche il codice che copia una sola riga dei duplicati di quella stazione per quella data ?

Quindi, per il file che hai allegato al post #1, dovrebbe scrivere solo una riga:

ID	X.U.FEFF.CountryCode	MRU	Region	NationalStationID	SeaDepth	Year	Month	Day	Time	SampleID	Determin_Nutrients	NutrientsSeawater_unit	LOD_LOQ_Flag	Concentration	SampleDepth	LOQ	LOD	AnalyticalMethod	Remarks	Station	Time
278127	IT	ISCMS	Basilicata	M1_SINNI_3	670	2019	9	26	10:59:41	M1_SINNI_3_2019_09_CF_716	Temperature (water)	°C		16,19	100			NA		ITNUT19-MSFD-00000000M1_SINNI_3	2019-09-26T10:59:41.000

ho capito bene?

[planera63Partecipante planera63]

Aldo Ercolini ha scritto:

Corretto.

Ciao Aldo.

Purtroppo dopo 12 ore il programma ancora non aveva terminato e l' ho terminato.

Forse copiando solo un solo record per profilo duplicato si velocizza. 

Appena arrivo in ufficio mando un esempio e una spiegazione dettagliata di  quello che intendo sia per per te, per scossa e gli altri.

[OscarPartecipante Oscar Karma: 45 pts]

scossa ha scritto:

Ma così sfalsi il campo ID e non credo che sia una bella cosa (di solito è un campo chiave).

P.S.: hai un pc potente, sul mio pc vecchiotto impiega circa 9 secondi.

Ciao Scossa , ma il campo ID deve sempre essere progressivo non lo puoi interrompere , ma lo puoi anche eliminare insieme al duplicato, ma poi dopo hai il salto

SI ho un PC potente AMD rizen 9-7950 X

[OscarPartecipante Oscar Karma: 45 pts]

Così elimina anche il campo ID

`Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ur = Range("A" & Rows.Count).End(xlUp).Row
For X = 2 To ur
For I = 3 To 22
Cells(X, 2) = Cells(X, 2) & "*" & Cells(X, I)
Next
Next

Range("c2" & ":v" & ur) = ""

    Range("B1").Activate
    ActiveSheet.Range("$A$1:$B$2147").RemoveDuplicates Columns:=2, Header:=xlYes
    
    Range("B2:B1432").Select
    Selection.TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="*", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1)), TrailingMinusNumbers:=True
        el = Range("A" & Rows.Count).End(xlUp).Row
        MsgBox "Sono stati eliminati  " & ur - el & "  Duplicati"
Range("A1").Select
End Sub
`

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

@oscar
Complimenti per la Selection.TextToColumns....

@scossa
Ho fatto quanto hai scritto =Eliminate 0 righe ed foglio2 con solo l'intestazione???

@planera63
Aspetto un files con una spiegazione migliore

[planera63Partecipante planera63]

scossa ha scritto:

Quindi, per il file che hai allegato al post #1, dovrebbe scrivere solo una riga:

ID X.U.FEFF.CountryCode MRU Region NationalStationID SeaDepth Year Month Day Time SampleID Determin_Nutrients NutrientsSeawater_unit LOD_LOQ_Flag Concentration SampleDepth LOQ LOD AnalyticalMethod Remarks Station Time 278127 IT ISCMS Basilicata M1_SINNI_3 670 2019 9 26 10:59:41 M1_SINNI_3_2019_09_CF_716 Temperature (water) °C 16,19 100 NA ITNUT19-MSFD-00000000M1_SINNI_3 2019-09-26T10:59:41.000

ho capito bene?

Si hai capito bene, solo una riga tra i 715 duplicati, anche se questa è l'ultima riga delle acquisizioni del 26/9/2019 eseguita a 100m di profondità, va bene lo stesso. 

Se fosse la prima, però  

276698 IT ISCMS Basilicata M1_SINNI_3 670 2019 9 26 10:58:00 M1_SINNI_3_2019_09_CF_006 Chlorophyll a μg/l 0,19 0,5 NA ITNUT19-MSFD-00000000M1_SINNI_3 2019-09-26T10:58:00.000 

sarebbe meglio. Però non ti preoccupare a me serve solo per fare qualche verifica e capire se effettivamente si tratta sempre di duplicati; quindi o la prima o l'ultima va bene lo stesso.

Allora correggi la tua procedura per copiare solo 1 duplicato tra i duplicati di una stazione per una data ?

Se vuoi spiegazioni più dettagliate le trovo nel file che allego a Oscar e Federico che mi hanno chiesto maggiori spiegazioni e un foglio di esempio con quello che voglio.

[planera63Partecipante planera63]

Oscar ha scritto:

  Devi allegare un esempio con la data e spiegare cosa devi fare  io non l'ho spostata su un'altro foglio il mio è solo un esempio , ma meglio utilizzare un foglio Temp per non avere problemi

Per Federico, Aldo, Oscar e scossa

Nel file allegato trovate un foglio Temp che contiene un po' la struttura dei dati e di come vengono acquisiti. Inoltre indico con un esempio cosa desidero che faccia la routine. Spero che questa volta sia chiaro. Grazie comunque per l'aiuto.

Allegati:

You must be logged in to view attached files.

[scossaPartecipante scossa Karma: 37 pts]

Questo il codice modificato per scrivere solo una riga per stazione (nel file allegato fare doppio clic su una celle della prima riga  di Foglio1 per lanciare la macro):

Sub RemoveTwins()
  'by scossa
  'https://www.excelvba.it/forumexcel/forums/discussione/eliminazione-duplicati/
  
  Dim ws As Worksheet, wsTo As Worksheet
  Dim rngFr As Range, rngTo As Range
  Dim rCell As Range, rRow As Range
  Dim sKey As String, sItem As String, aRow As Variant
  Dim nRowDup As Long, j As Long
  Dim cValid As Collection, cDup As Collection
  Dim bCalc As XlCalculation

  Set cValid = New Collection
  Set cDup = New Collection
  Set ws = Foglio1
  Set rngFr = ws.UsedRange
  Set rngFr = Intersect(rngFr, rngFr.Range("H:O"))
  Set wsTo = Foglio2
  
  wsTo.UsedRange.Offset(1).ClearContents
  
  On Error Resume Next
  For Each rRow In rngFr.Rows
    aRow = rRow.Value
    With Application
      aRow = .Transpose(.Transpose(aRow))
    End With
    sKey = Join(aRow, "§")
    sItem = rRow.Offset(0, -7).Cells(1, 1).Value
    cValid.Add sItem, sKey
    If Err.Number Then cDup.Add rRow.Row
    Err.Clear
  Next rRow
  On Error GoTo 0
  With Application
    .ScreenUpdating = False
    j = 1
    For nRowDup = cDup.Count To 1 Step -1
      aRow = cDup.Item(nRowDup)
      With ws.Rows(aRow).EntireRow
        If Left(.Cells(1, 11), 18) <> Left(.Cells(1, 11).Offset(1), 18) Then
          j = j + 1
          .Copy wsTo.Rows(j)
        End If
        .Delete
      End With
      '.StatusBar = "riga " & aRow & " eliminata"
    Next
    .StatusBar = False
    .ScreenUpdating = True
  End With
  MsgBox "eliminate " & cDup.Count & " righe"
  Set cValid = Nothing
  Set cDup = Nothing
  Set rngFr = Nothing
  Set rngTo = Nothing
  Set ws = Nothing
  
End Sub

Allegati:

You must be logged in to view attached files.

[planera63Partecipante planera63]

scossa ha scritto:

Questo il codice modificato per scrivere solo una riga per stazione (nel file allegato fare doppio clic su una celle della prima riga  di Foglio1 per lanciare la macro):

Benissimo scossa. 

Con la versione precedente impiegava 35 secondi per copiare tutte le righe duplicate. Con questa in cui copia una sola riga 18 secondi.

Ho utilizzata la prima versione sui dati totali del 2019 e ha impiegato di sicuro meno di 40'; con precisione non posso dirlo perché sono andato a mensa e al ritorno aveva terminato.

Ora faccio delle verifiche sui duplicati che sono stati eliminati e copiati per vedere se effettivamente si tratta di duplicati .

Ti faccio sapere  

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

In ritardo, ma ci sono riuscito, veloce grazie al codice di OSCAR
Mi escono due righe, ma forse non avevo capito bene

Allegati:

You must be logged in to view attached files.

[Autore]

Articoli