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ść
Marecki 
Excel Expert



Wersja: Win Office 2019
Posty: 6876
Wysłany: 13-03-2013, 17:27   

To i ja dorzucę jeszcze jedno rozwiązanie wyłuskania unikatów, którego jeszcze tu nie było.
W jednym z wątków kolega Oshon pokazał mi jak się odnosić do pól Tabeli Przestawnej, i stąd narodził się pomysł, a z racji tego że wyniki są akceptowalne postanowiłem umieścić go tutaj.
Oto
Kod:
Sub Unikaty_Tabela_Przestawna()
    Dim NazwaArkusza As String: NazwaArkusza = "Tp"
    Dim OstW As Long: OstW = Sheets("Arkusz1").Range("A1").CurrentRegion.Rows.Count
    Dim i As Long
    Dim tp As PivotTable
    Dim pole As PivotField
    Dim el As PivotItem
    Dim tbl()
    Dim s As Single, t As Single

    s = Timer

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False

        On Error Resume Next
        Do
            i = i + 1
            With Sheets(NazwaArkusza & i): End With
        Loop While Err = 0
        On Error GoTo 0

        NazwaArkusza = NazwaArkusza & i
        Sheets.Add.Name = NazwaArkusza

        Sheets("Arkusz1").PivotTableWizard SourceType:=xlDatabase, SourceData:=Range("A1:A" & OstW).Address, TableDestination:=Sheets(NazwaArkusza).Range("A1")

        With ActiveSheet

            Set tp = .PivotTables(1)
            .PivotTables(1).PivotFields(Sheets("Arkusz1").Range("A1").Value).Orientation = xlPageField
            Set pole = .PivotTables(1).PageFields(Sheets("Arkusz1").Range("A1").Value)

            ReDim Preserve tbl(1 To pole.PivotItems.Count)
            i = 1
            For Each el In pole.PivotItems

                If el.Name = "(blank)" Then Exit For
                tbl(i) = el.Name
                i = i + 1
            Next

            .Delete
            Range("G2").Resize(UBound(tbl)) = Application.Transpose(tbl)
        End With

        Erase tbl
        Set tp = Nothing
        Set pole = Nothing

        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    t = Timer
    Range("H7").Value = t - s
End Sub

Czyli jak widać kod tworzy Tabelę Przestawną w nowym tymczasowym arkuszu i z niej pobiera listę unikatów - już posortowaną.
Rozwiązanie takie staje się bardzo przydatne w chwili gdy już mamy utworzoną TP , a musimy unikaty umieścić w innym miejscu skoroszytu.

Wcześniej napisałem "wyniki akceptowalne" aleeee, no właśnie.
Są dwa oblicza tego "ale":
1. dla małej ilości unikatów powiedzmy 36-ciu wybieranych z 50k. jak jest pokazane w załączniku czas jest rewelacyjny.
2. dla 40k. unikatowych wartości wybieranych z 50k. czas ten się wydłuża 40-sto krotnie :-(
Ot i tyle.

W załączniku zebrane kody i pokazane czasy wykonywania poszczególnych procedur.

P/S
Taka mała ciekawostka (przynajmniej dla mnie)
Zmieniając komórkę "A1", czyli Dane1 na Dane kod mój się wysypuje - nie przyjmuje wartości Dane, z kolei tworząc ręcznie TP wartość ta już mu nie wadzi.
Dlaczego tak jest :?: :?: :?: :roll:

Unik.testy.rar
Pobierz Plik ściągnięto 470 raz(y) 343.09 KB

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 189400 Skopiuj do schowka
 
 
OShon 
Excel Expert



Zaproszone osoby: 383
Posty: 8272
Wysłany: 14-03-2013, 09:44   

Ano zastanawiające zjawisko z tą nazwą kolumny, ponieważ w kodzie nie masz żadnego odwołania do tej nazwy a arkusz nie zawiera obszaru, który by konfliktował z nazwa kolumny. Ciekawostka - jak zabronione nazwy arkuszy.
_________________
Oskar Shon - MVP Office System/Development 11/19r, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Sprawdź promocje na polskie dodatki do MS Office w VBATools.pl
ID posta: 189420 Skopiuj do schowka
 
 
Zbiniek 
Excel Expert



Zaproszone osoby: 2
Wersja: Win Office 2013
Posty: 2576
Wysłany: 17-04-2014, 06:07   

Podam tylko linkę do postu, w którym szbill62 podaje formułę dość długawą (żeby nie powiedzieć długą ;-) ), jednak na dużych zakresach działającą szybko -> http://www.excelforum.pl/viewtopic.php?p=224379
Linka do całego tematu -> http://www.excelforum.pl/...wej-vt40825.htm
_________________
pozdrawiam
Zbiniek

Pisz po polsku! Jest różnica czy siedzisz w sadzie czy w sądzie. "Język polski jest ą-ę" :-)

Prawdopodobieństwo otrzymania satysfakcjonującej odpowiedzi jest proporcjonalne do właściwego sformułowania problemu (popartego załącznikiem).

Jest załącznik - jest impreza

http://rtfm.killfile.pl/
ID posta: 224424 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Posty: 6876
Wysłany: 19-04-2018, 13:05   

Co prawda już padły rozwiązania wykorzystujące kolekcję i słownik, ale podam je jeszcze raz bo są ciut zmienione - "podrasowane".
Kolekcja:
Kod:
Function Unique_Value_Col(MyObj As Variant) As Variant
    Dim objColl               As Collection
    Dim i                     As Long
    Dim el                    As Variant

    Set objColl = New Collection

    On Error Resume Next
    If TypeName(MyObj) = "Range" Then
        For Each el In MyObj
            objColl.Add el.Value, Key:=CStr(el.Value)
        Next el
    Else
        For Each el In MyObj
            objColl.Add el, Key:=CStr(el)
        Next el
    End If

    ReDim VArr_Out(1 To objColl.Count, 1 To 1)

    For i = 1 To objColl.Count
        VArr_Out(i, 1) = objColl(i)
    Next i

    Unique_Value_Col = VArr_Out

    Set objColl = Nothing
    On Error GoTo 0

End Function

Słownik:
Kod:
Function Unique_Value_Dic(MyObj As Variant, Optional VbCompareMethod As Byte = 0) As Variant
'VbCompareMethod
'0 = vbBinaryCompare
'1 = vbTextCompare
    Dim objDic                As Object
    Dim el                    As Variant
    Dim i                     As Long
    Dim VArr_Out()            As Variant

    Set objDic = CreateObject("Scripting.Dictionary")
    objDic.CompareMode = VbCompareMethod

    If TypeName(MyObj) = "Range" Then
        For Each el In MyObj
            objDic(el.Value) = 1
        Next el
    Else
        For Each el In MyObj
            objDic(el) = 1
        Next el
    End If

    ReDim VArr_Out(1 To objDic.Count, 1 To 1)

    For Each el In objDic.keys()
        i = i + 1
        VArr_Out(i, 1) = el
    Next el

    Unique_Value_Dic = VArr_Out

    Set objDic = Nothing

End Function

Funkcje o tyle elastyczne że można do nich wrzucić tablicę lub zakres, który może być nieciągły np: Range("D14,A6:G7,B11:B13,B18:D21,C11:F24,D19:F29,F4:F28")
W załączniku pokazane rozwiązania i testy prędkościowe porównujące te dwie metody.
Metoda słownikowa jest dużo szybsza.

uni.xlsm
Pobierz Plik ściągnięto 71 raz(y) 27.79 KB

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 344735 Skopiuj do schowka
 
 
OShon 
Excel Expert



Zaproszone osoby: 383
Posty: 8272
Wysłany: 03-10-2018, 17:09   

No to taka nowość: Jak uzyskac unikaty i posortowane unikaty nową formułą
Dodatkowo fajny gadżet związany z wprowadzeniem notacji #, który odnosić się będzie do aktywnego obszaru.
_________________
Oskar Shon - MVP Office System/Development 11/19r, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Sprawdź promocje na polskie dodatki do MS Office w VBATools.pl
ID posta: 353785 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