Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - 41. Unikaty

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

I jeszcze jedno podejście do tematu Unikatów za pomocą obiektu słownikowego (zachęcił mnie m_m):

Kod:

Sub UnikatySłownik()
Dim TblK
Dim tbl(), tbl1()
Dim a&, i&, x&

a = Cells(Rows.Count, "A").End(xlUp).Row
tbl = Application.Transpose(Range("A2:A" & a))
Set TblK = CreateObject("Scripting.Dictionary")

For i = LBound(tbl) To UBound(tbl)
If Not TblK.Exists(tbl(i)) Then
x = x + 1
ReDim Preserve tbl1(1 To x)
tbl1(x) = tbl(i)
TblK.Add tbl(i), 1
End If
Next i

Cells(2, 2).Resize(UBound(tbl1)) = Application.Transpose(tbl1)
End Sub

P. S. Jeżeli da się obiekt słownikowy wrzucić bezpośrednio do zakresu komórek bez pośredniego wykorzystania tablicy, to chętnie bym zobaczył jak to zrobić :)

Unik.słownik.rar

Pobierz Plik ściągnięto 799 raz(y) 9.81 KB

master_mix · Excel Expert Wersja: Win Office 365 Posty: 2637

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

Zrobiłem testy szybkościowe, odpaliłem poniższe makra na 50k danych:

Kod:

Sub UnikatyCollectionZTab()

Dim NoDupes As New Collection
Dim tbl(), tbl1()
Dim a&, i&, x&
Dim s As Single, t As Single

s = Timer
a = Cells(Rows.Count, "A").End(xlUp).Row
tbl = Range("A2:A" & a).Value

On Error Resume Next
For i = LBound(tbl) To UBound(tbl)
NoDupes.Add 1, CStr(tbl(i, 1))
If Err.Number = 0 Then
x = x + 1
ReDim Preserve tbl1(1 To x)
tbl1(x) = tbl(i, 1)
Else
Err.Clear
End If
Next i

Cells(2, 2).Resize(UBound(tbl1)) = Application.Transpose(tbl1)

t = Timer
MsgBox t - s
End Sub

Sub UnikatySłownikTab()
Dim TblK
Dim tbl(), tbl1()
Dim a&, i&, x&
Dim s As Single, t As Single

s = Timer
a = Cells(Rows.Count, "A").End(xlUp).Row
tbl = Application.Transpose(Range("A2:A" & a))
Set TblK = CreateObject("Scripting.Dictionary")

For i = LBound(tbl) To UBound(tbl)
If Not TblK.Exists(tbl(i)) Then
x = x + 1
ReDim Preserve tbl1(1 To x)
tbl1(x) = tbl(i)
TblK.Add tbl(i), 1
End If
Next i

Cells(2, 2).Resize(UBound(tbl1)) = Application.Transpose(tbl1)
t = Timer
MsgBox t - s
End Sub

Sub UnikatySłownikBezTab()

Dim TblK
Dim tbl()
Dim a&, i&, x&
Dim s As Single, t As Single

s = Timer
a = Cells(Rows.Count, "A").End(xlUp).Row

If a > 2 Then

tbl = Range("A2:A" & a).Value

Set TblK = CreateObject("Scripting.Dictionary")
x = 1

On Error Resume Next
For i = LBound(tbl) To UBound(tbl)
TblK.Add tbl(i, 1), 1
If Err.Number = 0 Then x = x + 1 Else Err.Clear
Next i
On Error GoTo 0

Cells(2, 2).Resize(TblK.Count) = Application.Transpose(TblK.keys)

End If
t = Timer

MsgBox t - s
End Sub

Sub UnikatyCollectionBezTab()
Dim Cell As Range
Dim NoDupes As New Collection
Dim a&, x&, Item As Variant
Dim s As Single, t As Single

s = Timer
a = WorksheetFunction.CountA(Range("A:A"))

On Error Resume Next
For Each Cell In Range("A2:A" & a)
NoDupes.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0

x = 2
Range("B2:B" & a).ClearContents

For Each Item In NoDupes
Cells(x, 2).Value = Item
x = x + 1
Next Item
t = Timer

MsgBox t - s
End Sub

Uwagi.
1. Kolejność makr: od najszybszego do najwolniejszego
2. Pierwsze trzy makra mają czasy porównywalne, czwarte jest znacznie wolniejsze od pozostałych
3. Pierwsze makro z wykorzystaniem kolekcji i wpisaniem jej elementów do tablicy jest znacznie szybsze (4-5 razy) niż makro z wykorzystaniem kolekcji i wypisywaniem jej elementów w pętli do komórek (to jest w miarę oczywiste)
4. Najbardziej zaskakujące: szybsze jest wykorzystanie słownika łowiącego unikaty + wpisywanie elementów do tablicy niż wpisanie od razu słownika do zakresu :shock:

Pozdrawiam.

wuzeq · ExcelSpec Posty: 487

Mi wyniki wychodzą mniej więcej takie (50k 5cyfrowych losowych liczb):

Kod:

0,484375
0,2851563
0,2148438
101,4688

Czyli trochę odwrotnie:)

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

Testowałem teraz na danych liczbowych (spora ilość Unikatów), dostałem wyniki pod względem kolejności szybkości takie jak Ty (czyli raczej zgodne z intuicją), przetestuj jeszcze proszę wuzeq na moich danych, wcześniej testowałem na danych tekstowych, właśnie tutaj się pojawiają ciekawe spostrzeżenia lub mój komp nie wyrabia... :mrgreen:

Unik.testy.rar

Pobierz Plik ściągnięto 804 raz(y) 158.04 KB

master_mix · Excel Expert Wersja: Win Office 365 Posty: 2637

Już się pogubiłem co wy chłopaki liczycie :mrgreen:

Dodam jeszce ważną rzecz:
Przy deklaracji wcześnie wiązanej obiekt jest ZNACZNIE szybszy.

kolekcję macie wcześnie wiązaną a słownik nie ;)

Kod:

Dim TblK As Dictionary

Set TblK = New Dictionary

po wcześniejszym dodaniu referencji do Microsoft Scripting Runtime

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

Witam,
zainspirowany dzisiaj przez bodka postanowiłem przetestować szybkościowo w VBA wbudowaną funkcjonalność arkuszową USUŃ.DUPLIKATY :) Bez wątpienia kod jest najkrótszy :mrgreen:

Kod:

Sub UsunDup()
Dim s As Single, t As Single

s = Timer
Range("$A$1:$A$50000").RemoveDuplicates Columns:=1
t = Timer

MsgBox t - s
End Sub

Jednak okazuje się że USUŃ.DUPLIKATY jest wolniejsza tylko od kolekcji wyławiającej unikaty (popatrz cztery posty wyżej). :mrgreen:

W każdym razie jest to chyba najwygodniejsze narzędzie do wyławiania Unikatów :)

Uwaga. (Quasi)
Funkcjonalność USUŃ.DUPLIKATY jest czuła na formatowanie komórek, dlatego należy ją stosować ostrożnie (załącznik).

3x100.rar

Pobierz Plik ściągnięto 805 raz(y) 7.56 KB

Wormsek · Zaproszone osoby: 2 Wersja: Win Office 2016 Posty: 5295

Nie znam narzędzia i niestety nie mam czasu się pobawić, więc mam pytanko.

A czy działa to tylko na obiekt Range, czy na tablicę też zadziała?

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

Wydaje mi się, ale nie jest pewien, że jest to narzędzie tylko przypisane do obiektu Range. Ale to nie jest problem, można przecież wrzucić tablicę do pomocniczego zakresu, zastosować USUŃ.DUPLIKATY i zakres wrzucić z powrotem do tablicy, też powinno w miarę szybko zadziałać :)

tom1977 · ExcelSpec Posty: 806

Wormsek, Na tablice pewnie nie.
Swego czasu borykałem się w VBA z użyciem usuń duplikaty (chodziło mi usunięcie duplikatów wierszy za pomocą tego polecenia a żeby można to było zrobić trzeba podać numery kolumn w tabeli (ex 2007) - zarejestrujcie sobie makro to zobaczycie i nijak nie mogłem poradzić sobie z podaniem tej tablicy w granicznych wartościach od do zamiast wyszczególniać kolejne numery) i tu z pomocą przybył wielki nieobecny tego forum niejaki Tajan podsuwając taką sztuczkę (mój oryginalny post chyba przepadł po ostatniej awarii podforum "tematy ogólne"

Kod:

Sub usun_duplikaty()
Dim i&, st&

With ActiveSheet.UsedRange
For i = 1 To .Columns.Count - 1
st = st & i & ","
Next i

st = Left(st, Len(st) - 1)

Application.Run "'usunDuplikaty """ & _
.Address(External:=True) & _
"""," & st & "'"
End With
End Sub

Sub usunDuplikaty(zakres As String, ParamArray tbl())
Range(zakres).RemoveDuplicates tbl, xlNo
End Sub

jak do tej pory najszybszy sposób do usuwania duplikatów jaki widziałem

poprawnie deklaracje

master_mix · Excel Expert Wersja: Win Office 365 Posty: 2637

Dla mnie bomba ;-)

Jakiś czas temu chciałem zebrać w całość wszystkie "sztuczki" i mądrości Tadzia, ale za dużo chłop pisał i nie dobrnąłem do końca :mrgreen:

Nie mówiąc już ile przepadło...... :evil:

negatyv · Excel Expert Zaproszone osoby: 393 Posty: 1720

Są tylko dwa wpisy z formułami, to ja jeszcze dodam poniższe. Działa nie tylko na liczbach. Dane wejściowe są w komórkach A2:A9. Formuła do wpisania w C2 i przeciągnięcia w dół.

Kod:

=JEŻELI.BŁĄD(INDEKS($A$2:$A$9;PODAJ.POZYCJĘ(0;LICZ.JEŻELI($A$2:$A$9;"<"&$A$2:$A$9)-SUMA(LICZ.JEŻELI($A$2:$A$9;$C$1:C1));0));"")

sortowanie_unikaty.zip

Pobierz Plik ściągnięto 933 raz(y) 7.82 KB

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

Jeszcze jedno zagadnienie. Od dłuższego czasu korzystam przy różnego rodzaju makrach z bardzo użytecznej funkcji RndInt listującej losowo całkowite Unikaty, przerobionej ciut z WalkenBacha:

Kod:

Function RndInt(a As Long)
Dim V() As Variant, Val As Variant
Dim i&, j&, r&, c&
Dim t1 As Variant, t2 As Variant

Randomize

ReDim V(1 To a)
ReDim Val(1 To 2, 1 To a)

For i = 1 To a
Val(1, i) = Rnd
Val(2, i) = i
Next i

For i = 1 To a
For j = i + 1 To a
If Val(1, i) > Val(1, j) Then
t1 = Val(1, j)
t2 = Val(2, j)
Val(1, j) = Val(1, i)
Val(2, j) = Val(2, i)
Val(1, i) = t1
Val(2, i) = t2
End If
Next j
Next i

i = 0
For r = 1 To a
i = i + 1
V(i) = Val(2, i)
Next r

RndInt = V
End Function

Okazuje się, że przy 10000 elementów ta funkcja działa troche długo (parędziesiąt sekund). Okazuje się (jest to dla mnie małe zaskoczenie), że stosując metodę losowego wyszukiwania da się ten proces znacznie przyspieszyć. Kod mojej funkcji ma postać:

Kod:

Function RI(a As Long)
Dim i&, tbl(), w&
Dim NoDupes As New Collection

Randomize
For i = 1 To 100 * a
On Error Resume Next
w = Int(a * Rnd) + 1
NoDupes.Add 1, CStr(w)
If Err.Number = 0 Then
x = x + 1
ReDim Preserve tbl(1 To x)
tbl(x) = w
End If
If UBound(tbl) = a Then Exit For
Next i

RI = tbl
End Function

Po odpaleniu makra

Kod:

Sub xxx1()
Dim t1 As Single, t2 As Single, t3 As Single

t1 = Timer
tbl = RI(10000)
Cells(1, 1).Resize(10000) = Application.Transpose(tbl)
t2 = Timer

tbl = RndInt(10000)
Cells(1, 2).Resize(10000) = Application.Transpose(tbl)
t3 = Timer

MsgBox "Piersze makro: " & t2 - t1 & Chr(10) & "Drugie makro:" & t3 - t2
End Sub

okazuje się że moja funkcja dla 10k elementów działa o rząd wielkości szybciej (u mnie 80-90 razy szybciej), pozdrawiam.

PS. Przetestowałem szybkość działania obu funkcji dla 60k elementów, moja funkcja działa koło 300 razy szybciej :)

Trebor · Excel Expert Posty: 4680

Moja propozycja:

Kod:

Function RndInt(a As Long)
Dim V() As Variant, Dana&, i&, w&

Randomize

ReDim V(1 To a)

For i = 1 To a
V(i) = i
Next i

For i = 1 To a
w = Int((a - i + 1) * Rnd) + i
Dana = V(i)

V(i) = V(w)
V(w) = Dana

Next i

RndInt = V
End Function

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2803

Trebor, wygląda na to, że znalazłeś optymalne rozwiązanie, gratki :danke