Eliminare valori doppi.
Barbara
come devo fare per eliminare i valori doppi contenuti dentro una colonna al
fine di ottenere una colonna con solo valori univoci?
es colonna A
casa
mare
mare
mare
casa
neve
colonna B
casa
mare
neve
ciao Barbara
MauroAP
--
_ _ _
MauroAP
"Barbara" <Bar...@discussions.microsoft.com> ha scritto nel messaggio
news:BADC80E3-79F0-45AE...@microsoft.com...
Ciao Barbara puoi visitare il sito di ennius
http://ennius.altervista.org/free/ifvba43.htm
forse ti � utile .... � un mito!
Bruno Campanini
"Barbara" <Bar...@discussions.microsoft.com> wrote in message
news:BADC80E3-79F0-45AE...@microsoft.com...
-----------------------------------------------------
Public Sub Test8()
Dim SourceRange As Range, UniquesColl As New Collection
Dim TargetRange As Range, i, k As Long
' Definizioni
' --------------------------------
Set SourceRange = [Sheet10!J34]
Set TargetRange = [Sheet10!G34]
' --------------------------------
If Not IsEmpty(SourceRange(2, 1)) Then
Set SourceRange = SourceRange.Resize _
(SourceRange.End(xlDown).Row - SourceRange.Row + 1)
End If
For Each i In SourceRange
On Error Resume Next
UniquesColl.Add i, CStr(i)
Next
On Error GoTo 0
For i = 1 To UniquesColl.Count
k = k + 1
TargetRange(k) = UniquesColl(i)
Next
End Sub
-----------------------------------------------------
Bruno
plinius
"Barbara" <Bar...@discussions.microsoft.com> ha scritto nel messaggio
news:BADC80E3-79F0-45AE...@microsoft.com...
Questa funziona sulla selezione.
Selezioni la lista da cui eliminare i doppioni e, nella colonna alla sua
destra, vengono trascritti i dati senza doppioni.
Puoi collegarla ad un tasto di scelta rapido, oppure ad un pulsante.
--------------------------------------------------------------
Public Sub EliminaDoppioni()
Dim CurrentCell As Range, NextCell As Range
If Selection.Rows.Count < 2 Or Selection.Columns.Count > 1 Then
MsgBox "Selezionare almeno 2 righe in una sola colonna"
Exit Sub
End If
Application.ScreenUpdating = False
Selection.Copy Destination:=Selection.Offset(0, 1)
Selection.Offset(0, 1).Select
Set CurrentCell = Selection(1, 1)
Selection.Sort Key1:=CurrentCell
Do While Not IsEmpty(CurrentCell)
Set NextCell = CurrentCell.Offset(1, 0)
If NextCell.Value = CurrentCell.Value Then
CurrentCell.Clear
End If
Set CurrentCell = NextCell
Loop
Selection.Sort Key1:=CurrentCell
Selection(1, 1).Select
Application.ScreenUpdating = True
End Sub
--------------------------------------------------------------
Ciao,
E.
Mauro Gamberini
> al
> fine di ottenere una colonna con solo valori univoci?
> es colonna A
> casa
> mare
> mare
> mare
> casa
> neve
> colonna B
> casa
> mare
> neve
>
Seleziona una cella della tabella.
Dati--Filtro-->Filtro avanzato
Seleziona: Copia univoca dei record
Vedi tu dove vuoi i tuoi dati...
--
---------------------------
Mauro Gamberini
http://www.riolab.org/
http://blog.maurogsc.eu/
http://social.microsoft.com/Forums/it-IT/excelit/threads
Scossa
Propongo anche la mia versione: su un foglio con 21.759 righe per
9.829 valori unici impiega 1,28 secondi contro i 3,56 della sub
EliminaDoppioni() di Plinius e i 3,07 della sub Test8 di Bruno.
Sub Uniche()
' by Scossa
Dim rRng As Range
Dim rCella As Range
Dim nCnt1 As Long
Dim nCol As Long
Dim nCnt3 As Long
Dim nLastR As Long
Dim nStart As Double
Dim xlcalc As XlCalculation
With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With
nCol = Selection.Column
nLastR = Cells(Rows.Count, nCol).End(xlUp).Row
Set rRng = ActiveCell.Resize(nLastR, 1)
With rRng
nCnt3 = 4
Set rCella = .Cells(1, 1)
nStart = Timer
For nCnt1 = 1 To nLastR
If .Cells(nCnt1, 1) <> .Cells(nCnt1 + 1, 1) Then
With rCella
nCnt3 = nCnt3 + 1
Cells(nCnt3, .Column + 1).Value = .Value
End With
Set rCella = .Cells(nCnt1 + 1, 1)
End If
Next nCnt1
MsgBox "elapsed time: " & Timer - nStart
End With
rRng.Cells(1, 1).Select
Application.ActiveWindow.ScrollRow = 1
Set rRng = Nothing
Set rCella = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With
End Sub
Bye!
Scossa
Scossa
>
> Propongo anche la mia versione: su un foglio con 21.759 righe per
> 9.829 valori unici impiega 1,28 secondi contro i 3,56 della sub
> EliminaDoppioni() di Plinius e i 3,07 della sub Test8 di Bruno.
>
Ovviamente con .screenupdate=false e .Calculation = xlmanual in tutte
Bye!
Scossa
Scossa
Ad onor del vero non avevo notato che i dati du Barbara non sono
ordinati, mentre la mia sub prevede che i dati uguali siano
consecutivi ... basterebbe ordinatrli prima del ciclo for ma ora non
ho tempo ... per cui mi cospargo il capo di cenere e mi inginocchio
sui ceci ...
Bye!
Scossa
r
> On 1 Ott, 14:59, Barbara <Barb...@discussions.microsoft.com> wrote:
> > Ciao a tutti,
> >
> > come devo fare per eliminare i valori doppi contenuti dentro una colonna al
> > fine di ottenere una colonna con solo valori univoci?
> > es colonna A
> > casa
> > mare
> > mare
> > mare
> > casa
> > neve
> > colonna B
> > casa
> > mare
> > neve
> >
> > ciao Barbara
>
> Propongo anche la mia versione: su un foglio con 21.759 righe per
> 9.829 valori unici impiega 1,28 secondi contro i 3,56 della sub
> EliminaDoppioni() di Plinius e i 3,07 della sub Test8 di Bruno.
così al volo ... aggiungo uno spunto ...
Sub test()
ThisWorkbook.Worksheets.Add
[a1] = "titolo"
[a2:a65000].FormulaR1C1 = "=INT(20000*RAND()+1)"
[a1:a65000].Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Secondo_step
End Sub
Sub Secondo_step()
Dim PC As Excel.PivotCache
Dim PT As Excel.PivotTable
Dim rng1 As Excel.Range
Dim Rng2 As Excel.Range
Dim s As String, s2 As String
Dim d As Double
d = Timer
Set rng1 = Application.Intersect(ActiveSheet.UsedRange, [a:a])
s2 = rng1(1).Value
Set Rng2 = Nuovo_Range(ActiveWorkbook, "ShPivot")
s = "pvt" & Rng2.Parent.Name
Set PC = ActiveWorkbook.PivotCaches.Add _
(SourceType:=xlDatabase, SourceData:=rng1)
Set PT = PC.CreatePivotTable _
(TableDestination:=Rng2.Offset(2), _
TableName:=s)
With PT
.AddDataField .PivotFields(s2)
.PivotFields(s2).Orientation = xlRowField
End With
MsgBox Timer - d
End Sub
Function Nuovo_Range( _
Wb As Excel.Workbook, _
Optional Nome_base As _
String = "Foglio") As Excel.Range
'di Roberto Mensa - Nick r
'restituisce la cella A1 di un nuovo foglio
'il nuovo foglio viene rinominato in base
'all'argomento Nome_base
Dim b
Set Nuovo_Range = Wb.Worksheets.Add.Range("A1")
Application.ScreenUpdating = False
On Error Resume Next
Do
Err.Clear
Nuovo_Range.Parent.Name = Nome_base & b
b = b + 1
Loop While Err
Application.ScreenUpdating = True
End Function
saluti
r
--
Come e dove incollare il codice:
http://www.rondebruin.nl/code.htm
Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html
Mauro Gamberini
Ciao Roberto.
Ma allora sono l'unico che non ha capito?
Ma un semplice filtro sulla colonna
(o sulle colonne), buttando
una volta tanto il vb, non va bene?
Mah...
r
> <cut>
>
> Ciao Roberto.
> Ma allora sono l'unico che non ha capito?
> Ma un semplice filtro sulla colonna
> (o sulle colonne), buttando
> una volta tanto il vb, non va bene?
> Mah...
ciao Mauro ...
direi che va benissimo ...
ma l'avevi già detta te :-)
r
> <cut>
>
> Ciao Roberto.
> Ma allora sono l'unico che non ha capito?
> Ma un semplice filtro sulla colonna
> (o sulle colonne), buttando
> una volta tanto il vb, non va bene?
> Mah...
però ... pensavo fosse più veloce il filtro ...
beh poca importanza ...
Mauro Gamberini
>> Ma allora sono l'unico che non ha capito?
>> Ma un semplice filtro sulla colonna
>> (o sulle colonne), buttando
>> una volta tanto il vb, non va bene?
>> Mah...
>
> ciao Mauro ...
> direi che va benissimo ...
>
Ho visto che pioveva vb da tutte le parti... ;-)
Ciao e buon fine settimana.
Scossa
>
> così al volo ... aggiungo uno spunto ...
>
Ciao Roberto,
davvero interessante l'utilizzo della pivot, anche se un po' troppo
"invasivo".
Routine comunque velocissima!
Bye!
Scossa
Scossa
>
> però ... pensavo fosse più veloce il filtro ...
> beh poca importanza ...
>
So che parlare di velocità è sempre assai relativo, ma è solo uno
spunto....
Premessa: range generato una volta con la Sub test(): 64.999 righe
con 19.194 valori univoci
La routine che mi ispirava di più era quella di Bruno che utilizza la
collection, però è anche la più lenta.
Mi sono chiesto qual'era il collo di bottiglia e, test alla mano,
direi che la risposta è nel secondo ciclo for:
For i = 1 To UniquesColl.Count
k = k + 1
TargetRange(k) = UniquesColl(i)
Next
Allora ho pensato di eliminarlo integrando il tutto nel cilco di
popolamento della collection:
On Error Resume Next
For Each i In SourceRange
UniquesColl.Add i, CStr(i)
If Err.Number = 0 Then _
TargetRange.Offset(UniquesColl.Count - 1, 0) = i
Err.Clear
Next
On Error GoTo 0
I tempi passano da 10,5 secondi a 2,015 ... non male.
Facendo un ibrido, utilizzando nella mia routine originale la
collection
e un array il tempo scende a 1,28 (migliore di poco anche di quella
con
la pivot che si attesta su 1,5 secondi :-) )
Al di là dei meri tempi che poco contano, direi che l'idea di
integrare,
nel ciclo di alimentazione della collection, il popolamento del range
migliori decisamente l'efficienza.
Ci sono controindicazioni?
Questa la routine di Bruno modificata:
'==========================
Public Sub Test28()
Dim SourceRange As Range, UniquesColl As New Collection
Dim TargetRange As Range, i, k As Long, j As Long
Dim nStart As Double
Dim xlcalc As XlCalculation
' Definizioni
With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With
' --------------------------------
Set SourceRange = ActiveSheet.Range("E5")
Set TargetRange = ActiveSheet.Range("J5")
' --------------------------------
If Not IsEmpty(SourceRange(2, 1)) Then
Set SourceRange = SourceRange.Resize _
(SourceRange.End(xlDown).Row - SourceRange.Row + 1)
End If
nStart = Timer
On Error Resume Next
For Each i In SourceRange
UniquesColl.Add i, CStr(i)
If Err.Number = 0 Then _
TargetRange.Offset(UniquesColl.Count - 1, 0) = i
Err.Clear
Next
On Error GoTo 0
'For i = 1 To UniquesColl.Count
' k = k + 1
' TargetRange(k) = UniquesColl(i)
'Next
MsgBox "elapsed time: " & Timer - nStart
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With
End Sub
'==========================
Questa la mia:
'==========================
Sub Uniche2()
' by Scossa
Dim rRng As Range, rRng2 As Range
Dim aRng()
Dim i
Dim nCnt1 As Long, nCnt2 As Long
Dim nCol As Long
Dim nLastR As Long
Dim nStart As Double
Dim xlcalc As XlCalculation
Dim UniquesColl As New Collection
With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With
nCol = Selection.Column
nLastR = Cells(Rows.Count, nCol).End(xlUp).Row
Set rRng = ActiveCell.Resize(nLastR, 1)
nStart = Timer
With rRng
aRng = rRng.Value
Set rRng2 = rRng.Offset(0, 1).Cells(1, 1)
On Error Resume Next
nCnt1 = UBound(aRng)
For nCnt2 = 1 To nCnt1
UniquesColl.Add aRng(nCnt2, 1), CStr(aRng(nCnt2, 1))
If Err.Number = 0 Then _
rRng2.Offset(UniquesColl.Count - 1, 0) = aRng(nCnt2, 1)
Err.Clear
Next
On Error GoTo 0
MsgBox "elapsed time: " & Timer - nStart
End With
rRng.Cells(1, 1).Select
Application.ActiveWindow.ScrollRow = 1
Set rRng = Nothing
Set rRng2 = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With
End Sub
'==========================
Bye!
Scossa
r
"Scossa" ha scritto:
mi sembra che funzioni a dovere ...
per quanto riguarda i tempi ... mi sembra
d'averlo detto altre volte ... in memoria è
più veloce ... non l'ho provata a confronto
con la tua ... ma son sicuro che i tempi
saranno più brevi:
Sub test()
ThisWorkbook.Worksheets.Add
[a1] = "titolo"
[a2:a65000].FormulaR1C1 = "=INT(20000*RAND()+1)"
[a1:a65000].Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Secondo_step
End Sub
Sub Secondo_step()
Dim rng1 As Excel.Range
Dim C As Collection
Dim L1 As Long
Dim L2 As Long
Dim D As Double
Dim Arr(), Arr2()
Set C = New Collection
D = Timer
Set rng1 = Application.Intersect(ActiveSheet.UsedRange, [a:a])
Arr = rng1.Value
ReDim Arr2(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
L2 = 1
On Error Resume Next
For L1 = 1 To rng1.Rows.Count
C.Add L1, CStr(Arr(L1, 1))
If Err Then
Err.Clear
Else
Arr2(L2, 1) = Arr(L1, 1)
L2 = L2 + 1
End If
Next
On Error GoTo 0
rng1.Offset(0, 1).Resize(L2 - 1).Value = Arr2
MsgBox Timer - D
End Sub
plinius
"Scossa" <scos...@gmail.com> ha scritto nel messaggio
news:dd0e4b21-9170-41a9...@g1g2000vbr.googlegroups.com...So che parlare di velocit� � sempre assai relativo, ma � solo uno
spunto....
Premessa: range generato una volta con la Sub test(): 64.999 righe
con 19.194 valori univoci
Facendo un ibrido, utilizzando nella mia routine originale la
collection
e un array il tempo scende a 1,28 (migliore di poco anche di quella
con
la pivot che si attesta su 1,5 secondi :-) )
Bye!
Scossa
Rosicchiando fino all'ultimo centesimo di secondo la tua routine:
----------------
Sub Uniche2()
' by Scossa
Dim rRng As Range, rRng2 As Range
Dim aRng()
Dim i
Dim nCnt1 As Long, nCnt2 As Long
Dim nCol As Long
Dim nLastR As Long
Dim nStart As Double
Dim xlcalc As XlCalculation
Dim UniquesColl As New Collection
nStart = Timer
With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With
nCol = Selection.Column
nLastR = Cells(Rows.Count, nCol).End(xlUp).Row
Set rRng = ActiveCell.Resize(nLastR, 1)
With rRng
aRng = rRng.Value
Set rRng2 = rRng.Offset(0, 1).Cells(1, 1)
On Error Resume Next
nCnt1 = UBound(aRng)
For nCnt2 = 1 To nCnt1
UniquesColl.Add aRng(nCnt2, 1), CStr(aRng(nCnt2, 1))
If Err.Number = 0 Then _
rRng2.Offset(UniquesColl.Count - 1, 0) = aRng(nCnt2, 1)
Err.Clear
Next
On Error GoTo 0
End With
rRng.Cells(1, 1).Select
Application.ActiveWindow.ScrollRow = 1
Set rRng = Nothing
Set rRng2 = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With
MsgBox "elapsed time: " & Timer - nStart
End Sub
--------------------
... cos� cambiata...
(ciclo for each... next invece di for...next e accesso alle celle di target
senza usare l'offset)
--------------------
Sub Uniche3()
' by Scossa
Dim rRng As Range, rRng2 As Range
Dim aRng()
Dim i As Long, k As Long, v
Dim nCol As Long
Dim nLastR As Long
Dim nStart As Double
Dim xlcalc As XlCalculation
Dim UniquesColl As New Collection
nStart = Timer
With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With
nCol = Selection.Column
nLastR = Cells(Rows.Count, nCol).End(xlUp).Row
Set rRng = ActiveCell.Resize(nLastR, 1)
aRng = rRng
Set rRng2 = rRng.Offset(0, 1
)
Set rRng = Nothing
On Error Resume Next
For Each v In aRng
UniquesColl.Add v, CStr(v)
If Err.Number = 0 Then
k = k + 1
rRng2(k, 1) = v
End If
Err.Clear
Next
On Error GoTo 0
Application.ActiveWindow.ScrollRow = 1
Set rRng2 = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With
MsgBox "elapsed time: " & Timer - nStart
End Sub
--------------------
...guadagna altri 10/100 ca.
Si pu� fare altro? :-))
plinius
"r" <r...@discussions.microsoft.com> ha scritto nel messaggio
news:347BC0DD-B1F0-4CF2...@microsoft.com...
>
> mi sembra che funzioni a dovere ...
>
> per quanto riguarda i tempi ... mi sembra
> pi� veloce ... non l'ho provata a confronto
> con la tua ... ma son sicuro che i tempi
Altroch� se sono pi� brevi: si dimezzano quasi!!
Impiega poco 60/100 di secondo, piuttosto che 1 e rotti
:-))
r
>
> "Scossa" <scos...@gmail.com> ha scritto nel messaggio
> news:dd0e4b21-9170-41a9...@g1g2000vbr.googlegroups.com...
> On 2 Ott, 16:49, r <r...@discussions.microsoft.com> wrote:
> So che parlare di velocità è sempre assai relativo, ma è solo uno
> .... così cambiata...
> ....guadagna altri 10/100 ca.
>
> Si può fare altro? :-))
veramente questo non fa ciò che
dovrebbe ma l'esatto contrario ...
l'errore viene generato a chiave doppia ...
poi l'err.clear fatto indiscriminatamente ...
For Each v In aRng
UniquesColl.Add v, CStr(v)
If Err.Number = 0 Then
k = k + 1
rRng2(k, 1) = v
End If
Err.Clear
Next
vorrei poi farvi notare che lavorare in memoria ha
il suo maggior vantaggio (a livello di tempi) nella
scrittura dei valori nel range piuttosto che la sua
lettura (che già è abbastanza veloce)
disattivare il calcolo automatico, gli eventi ... non
ha nessun senso lavorando in memoria ...
un grosso vantaggio quando per es. si scrive procedure
con l'evento change...
l'aggiornamento dello schermo è spesso
trascurabile ...
r
>
> veramente questo non fa ciò che
> dovrebbe ma l'esatto contrario ...
ops ... letto di fretta ... usate err.number ...
per il resto le considerazioni rimangono le
stesse
r
> "r" ha scritto:
>
> >
> > veramente questo non fa ciò che
> > dovrebbe ma l'esatto contrario ...
>
> ops ... letto di fretta ... usate err.number ...
grrr.... intendevo =0 ... che contorti!
:-)
r
>
> "r" <r...@discussions.microsoft.com> ha scritto nel messaggio
> news:347BC0DD-B1F0-4CF2...@microsoft.com...
> >
> > mi sembra che funzioni a dovere ...
> >
> > per quanto riguarda i tempi ... mi sembra
> > d'averlo detto altre volte ... in memoria è
> > più veloce ... non l'ho provata a confronto
> > con la tua ... ma son sicuro che i tempi
> > saranno più brevi:
> Altroché se sono più brevi: si dimezzano quasi!!
> Impiega poco 60/100 di secondo, piuttosto che 1 e rotti
> :-))
>
bada però ... ha anche i suoi bei svantaggi ...
plinius
>
>
> bada per� ... ha anche i suoi bei svantaggi ...
> saluti
> r
> --
Svantaggi??
Non li vedo... un indizio...? :~|
r
>
> "r" <r...@discussions.microsoft.com> ha scritto nel messaggio
> news:ED376D63-E936-4FC5...@microsoft.com...
> >
> >
> > bada però ... ha anche i suoi bei svantaggi ...
> > saluti
> > r
> > --
>
> Svantaggi??
> Non li vedo... un indizio...? :~|
per esempio
un numero memorizzato come testo ...
diventa un numero ...
plinius
>> news:ED376D63-E936-4FC5...@microsoft.com...
>
> un numero memorizzato come testo ...
> diventa un numero ...
> saluti
> r
>
> --
Giustissimo, certo!
Ma si dovrebbe anche immaginare che chi usa la routine lo faccia sapendo a
che serve e come si comporta...
Ciao,
E. :-)
Scossa
>
> mi sembra che funzioni a dovere ...
>
> per quanto riguarda i tempi ... mi sembra
> d'averlo detto altre volte ... in memoria è
> più veloce ... non l'ho provata a confronto
> con la tua ... ma son sicuro che i tempi
> saranno più brevi:
>
> ReDim Arr2(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
Ecco, mi hai anticipato .. l'uso del secondo array era il mio possimo
step :-)
Siamo a 0,76 secondi
Ripeto, Al di là dei tempi è interessante la soluzione, anche se, come
hai fatto notare, c'è il problema dei numeri-testo convertiti in
valori.
Bye!
Scossa
Scossa
> (ciclo for each... next invece di for...next e accesso alle celle di target
> senza usare l'offset)
> --------------------
>
LOL, ottima, ma il record della variante di Roberto (0,76) credo sia
irragiungibile :-)
Bye!
Scossa
r
si da il caso che non sempre sia così ... comunque
mi trovi daccordo ...
è sempre bene sapere cosa ci sia di buono e
cosa di problematico ...
si potrebbe anche immaginare ... che non sia
l'unico problema ... che ce ne siano altri ... così
uno prova e sperimenta ... poi giudica
personalmente ho già dato ... :-)