Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 22640 Skopiuj do schowka 41. Unikaty
Autor Wiadomość
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 08-03-2012, 22:24   

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 368 raz(y) 9.81 KB

_________________
miasto nauki
ID posta: 151992 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Posty: 2098
Wysłany: 09-03-2012, 00:34   

hurgadion napisał/a:
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ć :)


Właśnie to tygryski lubią najbardziej :mrgreen:

Słownik ma tą zaletę że dostajemy dwie niezależne tablice

Kod:
Sub UnikatySłownik()

    Dim TblK   As Object
    Dim tbl()
    Dim a&, i&, x&

    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), "item" & x
            If Err.Number = 0 Then x = x + 1 Else Err.Clear
        Next i
        On Error GoTo 0

        'listujemy słownik jako dwie niezależne tablice
        Cells(2, 2).Resize(TblK.Count) = Application.Transpose(TblK.keys)
        Cells(2, 3).Resize(TblK.Count) = Application.Transpose(TblK.items)
       
        'lub za jednym zamachem
        'Cells(2, 2).Resize(TblK.Count, 2) = Application.Transpose(Array(TblK.keys, TblK.items))
       
    End If

End Sub
_________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Podejmę współpracę (pracę) w zakresie tworzenia aplikacji arkusza kalkulacyjnego z wykorzystaniem VBA. Programowanie VB.NET, ASP.NET, WPF. Technologie LINQ, Entity Framework. Aplikacje klienckie dla baz danych SQL Server, Oracle, MySQL
Wrocław i okolice …lub zdalnie.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ID posta: 151998 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 09-03-2012, 10:33   

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.
_________________
miasto nauki
ID posta: 152022 Skopiuj do schowka
 
 
wuzeq
ExcelSpec



Posty: 487
Wysłany: 09-03-2012, 11:11   

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

Kod:
 0,484375
 0,2851563
 0,2148438
 101,4688


Czyli trochę odwrotnie:)
ID posta: 152035 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 09-03-2012, 11:27   

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 384 raz(y) 158.04 KB

_________________
miasto nauki
ID posta: 152038 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Posty: 2098
Wysłany: 09-03-2012, 17:44   

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
_________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Podejmę współpracę (pracę) w zakresie tworzenia aplikacji arkusza kalkulacyjnego z wykorzystaniem VBA. Programowanie VB.NET, ASP.NET, WPF. Technologie LINQ, Entity Framework. Aplikacje klienckie dla baz danych SQL Server, Oracle, MySQL
Wrocław i okolice …lub zdalnie.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ID posta: 152109 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 21-05-2012, 09:10   

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 373 raz(y) 7.56 KB

_________________
miasto nauki
Ostatnio zmieniony przez hurgadion 21-05-2012, 09:17, w całości zmieniany 1 raz  
ID posta: 159691 Skopiuj do schowka
 
 
Wormsek 



Zaproszone osoby: 2
Wersja: Win Office 2016
Posty: 5267
Wysłany: 21-05-2012, 09:16   

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?
_________________
Pozdro
Worm

FAQ - Najczęściej zadawane pytania.
JAK KORZYSTAĆ Z SZUKAJKI
Słownik funkcji

Znajdź nas na Facebook'u

A może fajny dodatek do excela?
ID posta: 159692 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 21-05-2012, 09:18   

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ć :)
_________________
miasto nauki
ID posta: 159693 Skopiuj do schowka
 
 
tom1977 
ExcelSpec


Posty: 806
Wysłany: 21-05-2012, 09:34   

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
_________________
Tomek


W przypadku konieczności szerszej pomocy w Excel/VBA zapraszam do kontaktu na priv.
ID posta: 159694 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Posty: 2098
Wysłany: 21-05-2012, 13:27   

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:
_________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Podejmę współpracę (pracę) w zakresie tworzenia aplikacji arkusza kalkulacyjnego z wykorzystaniem VBA. Programowanie VB.NET, ASP.NET, WPF. Technologie LINQ, Entity Framework. Aplikacje klienckie dla baz danych SQL Server, Oracle, MySQL
Wrocław i okolice …lub zdalnie.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ID posta: 159733 Skopiuj do schowka
 
 
negatyv
Excel Expert



Zaproszone osoby: 393
Posty: 1720
Wysłany: 18-06-2012, 14:27   

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 500 raz(y) 7.82 KB

_________________
http://www.123office.pl - blog poświęcony programom pakietu MS Office.

Kurs VBA | LinkedIn
ID posta: 162282 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 08-10-2012, 15:49   

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 :)
_________________
miasto nauki
ID posta: 172351 Skopiuj do schowka
 
 
Trebor 
Excel Expert


Posty: 4680
Wysłany: 10-11-2012, 19:57   

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
_________________
Trebbor@wp.pl
ID posta: 176307 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 11-11-2012, 19:09   

Trebor, wygląda na to, że znalazłeś optymalne rozwiązanie, gratki :danke
_________________
miasto nauki
ID posta: 176356 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe