ID tematu: 22640
 |
41. Unikaty |
Autor |
Wiadomość |
Marecki
Excel Expert


Wersja: Win Office 2021
Posty: 8821
|
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
Unik.testy.rar
|
Pobierz Plik ściągnięto 890 raz(y) 343.09 KB |
|
_________________ Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.
FB |
|
 | ID posta:
189400
|
|
|
 |
|
|
|
OShon
Excel Expert

Zaproszone osoby: 416
Wersja: Win Office 365
Posty: 8386
|
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/24, 3xMCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA | GL Excel VBA
Dodatki do Office VBATools.pl, aktualne promocje, darmowe artykuły i literatura
|
|
 | ID posta:
189420
|
|
|
 |
|
|
Zbiniek
Excel Expert


Zaproszone osoby: 2
Wersja: Win Office 2013
Posty: 2676
|
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
|
|
|
 |
|
|
Marecki
Excel Expert


Wersja: Win Office 2021
Posty: 8821
|
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 486 raz(y) 27.79 KB |
|
_________________ Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.
FB |
|
 | ID posta:
344735
|
|
|
 |
|
|
OShon
Excel Expert

Zaproszone osoby: 416
Wersja: Win Office 365
Posty: 8386
|
|
 | ID posta:
353785
|
|
|
 |
|
|
|
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
|
|
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
|