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

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

Witam,
przeglądałem dzisiaj FAQ i nie zauważyłem żadnej wzmianki na ten temat, wydaje mi się, że jest to zagadnienie, które warto umieścić w FAQ. Mam trzy informacje na ten temat:

1. jest na ten temat artykuł napisany przeze mnie oraz użytkownika tkuchta1:
http://excelperfect.pl/?p=185

2. namierzyłem także bardzo ciekawą, listującą i sortującą unikaty funkcję napisaną przez Piotra_Korbicza, więcej na ten temat można poczytać w wątku:
http://www.excelforum.pl/...ghlight=unikaty

3. dzisiaj wykombinowałem nowy sposób wypisywania unikatów, makro jest oparte na funkcji Podaj.Pozycję i ma postać:

Kod:

Sub Unikaty()
Dim a&, c&, i&, x As Range

a = OstatniWiersz(Range("A:A"))
Range("B2:B" & a).ClearContents
Cells(2, 2).Value = Cells(2, 1).Value

c = 3
For i = 2 To a
Set x = Range("B1:B" & c)
If IsError(Application.Match(Cells(i, 1).Value, x, 0)) Then
Cells(c, 2).Value = Cells(i, 1).Value
c = c + 1
End If
Next i

Set x = Nothing
End Sub

Function OstatniWiersz(Zakres As Range) As Long
On Error Resume Next
With Zakres
OstatniWiersz = .Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
End With
On Error GoTo 0
End Function

Przykład jest umieszczony w załączniku, pozdrawiam wszystkich ewentualnych czytaczy :)

Edit: ponieważ link z punktu 2 (jak na razie) nie działa, więc odsyłam do linku związanego z funkcją p. Korbicza, w nim Kaper podał swoją wersję tej funkcji: http://www.excelforum.pl/...=unikat+korbicz

Unik.rar

Pobierz Plik ściągnięto 1182 raz(y) 8.73 KB

Trebor · Excel Expert Posty: 4680

Twój sposób jest dobry przy ciągłej liście. Jednak przy "pustych" komórkach nie będzie już tak różowo. Pozostaje jeszcze problem gdy będziemy chcieli odróżnić rekordy ze względu na wielkość liter.

Do sposobów wyżej podanych może jeszcze dodać projekt oparty na dwóch pętlach (mam nadzieję, że takiego w podanym linku nie ma)

Kod:

Sub Uni_Tr()
Dim i As Long, j As Long, ostatnia As Long, wiersz As Long
wiersz = 1
ostatnia = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)).ClearContents

For i = 2 To ostatnia
For j = i + 1 To ostatnia
If Cells(i, 1) = Cells(j, 1) Then Exit For
Next j
If j > ostatnia Then
wiersz = wiersz + 1
Cells(wiersz, 3) = Cells(i, 1)
End If
Next i
End Sub

Przy niewielkich zmianach kodu można go znacznie przyśpieszyć.
Pozdrawiam

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

No to ja też wejdę w ten temat :-)

Darek użył szybkiej funkcji podaj.pozycję do wyszukiwania czy element wprowadzany jest już w tablicy, bardzo ładnie...

Ja trochę przyspieszę i zadziałam na tablicy a nie bezpośrednio na komórkach.

Dodatkowo też odrzucimy puste, jak zasugerował Trebor, no i jeszcze dodatkowo unikaty zostaną posortowane.

Jednak nie użyjemy żadnych algorytmów sortujących tablicę, zrobimy to jeszcze szybciej ....
użyjemy ponownie funkcji podaj.pozycję z typem porównania ustawionym na 1
Znajdujemy największą wartość, która jest mniejsza lub równa wartości szukanej i za nią wstawiamy element, jednocześnie przesuwając resztę tablicy...

Kod:

Sub Unikaty()

Dim a&, x&, y&, i&, podmiana
Dim tbl()
Dim tblZakres()
Dim startowa&

a = OstatniWiersz(Range("A:A"))
If a < 2 Then Exit Sub
Range("B2:B" & a).ClearContents

On Error Resume Next
tblZakres = Application.Transpose(Range("A2:A" & a).Value)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
Range("B2").Value = Range("A2").Value
Else
On Error GoTo 0
y = 1
x = x + 1
ReDim Preserve tbl(1 To x)

Do While y <= UBound(tblZakres)
If Not IsEmpty(tblZakres(y)) Then
tbl(x) = tblZakres(y)
startowa = y + 1
Exit Do
End If
y = y + 1
Loop

For i = startowa To UBound(tblZakres)
If Not IsEmpty(tblZakres(i)) Then
If IsError(Application.Match(tblZakres(i), tbl, 0)) Then
On Error Resume Next
podmiana = (Application.Match(tblZakres(i), tbl, 1))
On Error GoTo 0
If IsError(podmiana) Then
podmiana = 1
x = x + 1
ReDim Preserve tbl(1 To x)
For y = x To podmiana + 1 Step -1
tbl(y) = tbl(y - 1)
Next y
tbl(podmiana) = tblZakres(i)
Else
x = x + 1
ReDim Preserve tbl(1 To x)
For y = x To podmiana + 2 Step -1
tbl(y) = tbl(y - 1)
Next y
tbl(podmiana + 1) = tblZakres(i)
End If
End If
End If
Next i

Range("B2").Resize(UBound(tbl)) = Application.Transpose(tbl)

End If

End Sub

Function OstatniWiersz(Zakres As Range) As Long

On Error Resume Next
With Zakres
OstatniWiersz = .Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
End With
On Error GoTo 0

End Function

Trebor · Excel Expert Posty: 4680

Po sortowaniu można by się spodziewać, że dla tych samych rekordów efekt końcowy będzie zawsze ten sam. Niestety po pomieszaniu tych samych rekordów efekt końcowy jest zmienny.

Jednak sam pomysł - bo o to tutaj chodzi - jest zaskakujący.

Pozdrawiam

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

Zapomniałem dodać że wynik będzie ten sam (dobry), gdy elementy są tego samego typu (albo Tekst, albo Liczby)

Można by pokusić się o "zuniwersalnienie" poprzez podział na 2 tablice , pozostając przy jednym przejściu przez tablicę przeszukiwaną żeby nie stracić na szybkości wykonywania procedury.

Jak będę miał kiedyś czas to popracuję nad tym...

OShon · Wysłany: 13-06-2011, 17:12

A ja dodam jeszcze taką drobinkę:

Kod:

Sub Unikaty_obok_kol()
Dim zakres As Range
Set zakres = Range("A1:A20")
zakres.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=zakres.Offset(, 1), Unique:=True
Set zakres = Nothing
End Sub

oraz

Kod:

Sub usun_duplukaty_2007()
Columns("A:A").Copy Columns("B:B")
Columns("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Aby pociągnąć temat tym sposobem proponuje pełne rozwiązanie:

Kod:

Sub Unikaty_kolumny()
Dim lit As String
lit = InputBox("Podaj literę kolumny, z jakiej będą pobrane unikaty!", _
"Unikaty", Split(Columns(ActiveCell.Column).Address(0, 0, xlA1, 0), ":")(0))
If Len(lit) > 0 Then Call unikaty_z_kolumny(lit)
End Sub

Private Sub unikaty_z_kolumny(litera As String)
Dim k&, cal As New Collection, x&, jest_kol As Boolean
Call BlockEvScreenCalc(False, "Przerabianie danych...")
For k = 1 To Columns.Count
If Split(Columns(k).Address(0, 0, xlA1, 0), ":")(0) = UCase(litera) Then
litera = k
jest_kol = True
Exit For
End If
Next k
If jest_kol = False Then GoTo brak_danych
If Cells(Rows.Count, k).End(xlUp).Row = 1 Then GoTo brak_danych
Columns(k + 1).Insert
Columns(k).Copy Columns(k + 1)
Columns(k + 1).RemoveDuplicates Columns:=1, Header:=xlNo
For x = 1 To Cells(Rows.Count, k + 1).End(xlUp).Row
UserForm1.ComboBox1.AddItem Cells(x, k + 1) 'do combo w formie
'cal.Add Cells(x, k + 1) 'do kolekcji
Next x
Columns(k + 1).Delete
brak_danych:
Call BlockEvScreenCalc(True)
With UserForm1.ComboBox1
If .ListCount > 0 Then .ListIndex = 0
.Parent.Show
End With
'MsgBox "Pobrano elementy do kolekcji: " & cal.Count, vbInformation, "VBATools.pl"
End Sub

Private Sub BlockEvScreenCalc(Optional ByVal bWlacz As Boolean, Optional Status As String)
On Error Resume Next
With Application
If bWlacz Then
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = ""
.ScreenUpdating = True
.Cursor = xlDefault
Else
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.StatusBar = Status
.Cursor = xlWait
End If
End With
End Sub

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

I jeszcze jedno rozwiązanie (w oparciu o pomysł z Walkenbacha, wykorzystanie kolekcji i jednej uwagi Quasi'ego). Makro ma postać:

Kod:

Sub Unikaty()
Dim Cell As Range
Dim NoDupes As New Collection
Dim a&, x&, Item As Variant

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" & 10000).ClearContents

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

Unik.NoDupes.rar

Pobierz Plik ściągnięto 972 raz(y) 8.75 KB

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

I jeszcze jedno rozwiązanie, chyba najkrótsze, ale nie wiem czy najłatwiejsze (nie wiem kto jest autorem, może ktoś wie ?) przypomniane niedawno przez SGJ w wątku: http://www.excelforum.pl/...4416.htm#128562 Tablicowa formułka bez obsługi błędów listująca unikaty ma postać:

Kod:

=INDEKS($A$2:$A$15;PODAJ.POZYCJĘ(0;LICZ.JEŻELI($B$1:B1;$A$2:$A$15);0))

W załączniku przykład, pozdrawiam.

Unik.najkrótsze.rar

Pobierz Plik ściągnięto 1179 raz(y) 9.07 KB

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

I jeszcze jedno rozwiązanie, tym razem formułka listująca i sortująca unikaty, ale tylko dla wartości liczbowych (działa także dla dwuwymiarowego zakresu):

Kod:

=MAX(JEŻELI(LICZ.JEŻELI($H$1:H1;$A$1:$E$5)=0;$A$1:$E$5;""))

Pozdrawiam.

Unik.sort.liczb.rar

Pobierz Plik ściągnięto 922 raz(y) 6.11 KB

mreck · Excel Expert Posty: 456

nie wiem kiedy, ale takie cos przyorałem, Unikaty
jak dla mnie trochę kosmos, ale gdyby ktoś chciałe popatrzeć (listing jest zbyt długi) to proszę w załączniku. Acha, dobrze jest przejrzeć stronkę, bo to dwie klasy wyżej od Tajana. ;-)

a komentarz jest bardzo pouczający. Kurcze, tak programować...

Unikaty.rar

Pobierz Plik ściągnięto 908 raz(y) 32.22 KB

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

I jeszcze jedno, z bardziej "przyziemnych rozwiązań" Proponuję losowe wyszukiwanie Unikatów (jest to moja ulubiona ostatnio metoda rozwiązywania problemów w Excelu). Proponuje kod:

Kod:

Sub LosoweUnikaty()
Dim tbl(), x As Range
Dim a&, i&, s&, m As String

Randomize

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

Set x = Range("A2:A" & a)

s = 1
For i = 1 To 10 * x.Count
If i = 1 Then
ReDim tbl(1 To s)
tbl(i) = Application.Index(x, Round(0.5 + x.Count * Rnd, 0))
Else
m = Application.Index(x, Round(0.5 + x.Count * Rnd, 0))
If Join(tbl) Like "*" & m & "*" Then
GoTo dalej:
Else
s = s + 1
ReDim Preserve tbl(1 To s)
tbl(s) = m
End If
End If

dalej:
Next i
Range("B2:B" & a).ClearContents
Cells(2, 2).Resize(UBound(tbl)) = Application.Transpose(tbl)
End Sub

Pozdrawiam wszystkich czytaczy.

Unik.losowe.rar

Pobierz Plik ściągnięto 840 raz(y) 7.68 KB

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

I jeszcze jedno, deterministyczne rozwiązanie (prostsze od tego powyżej), z wykorzystaniem (podobnie jak w powyższym przypadku) funkcji Join (zupełnie niechcąco podsunął mi rozwiązanie, a dokładnie użyteczną funkcję Join m_m w jednym wątku na GL), kod ma postać:

Kod:

Sub UnikatyJoin()
Dim tbl(), x As Range
Dim a&, i&, s&

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

s = 0
For i = 2 To a
If Join(tbl) Like "*" & Cells(i, 1).Value & "*" Then
GoTo dalej:
Else
s = s + 1
ReDim Preserve tbl(1 To s)
tbl(s) = Cells(i, 1).Value
End If

dalej:
Next i
Cells(2, 2).Resize(UBound(tbl)) = Application.Transpose(tbl)
End Sub

Pozdrawiam.

Unik.Join.rar

Pobierz Plik ściągnięto 844 raz(y) 9.11 KB

OShon · Wysłany: 23-09-2011, 15:55

Napisałem dzisiaj 3 funkcje (a potem je jeszcze podrasowałem także przepraszam za nadmierną edycję posta) - może się wam przyda. Ubrałem to w artykuł

Ilość unikatów dla wskazanego obszaru
Ilość unikatów dla stringa
Lista unikatów dla poprawności danych/lista

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

I kolejny przykład, tym razem służący znalezieniu unikalnych rekordów. W rozwiązaniu pojawia się kolekcja, ale jest ona tylko testem na unikatowość danego rekordu (pomysł Artika). Kod ma postać:

Kod:

Sub UnikalneRekordy()
Dim i&, x&, tbl1(), tblp(), a As String
Dim NoDupes As New Collection

ReDim tbl1(1 To 4)

For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
tbl1 = Application.Transpose(Application.Transpose(Range("A" & i & ":D" & i).Value))
a = Join(tbl1, "_")

On Error Resume Next

NoDupes.Add 1, a
If a <> Application.Rept("_", 3) And Err.Number = 0 Then
x = x + 1
ReDim Preserve tblp(1 To 4, 1 To x)
For j = 1 To 4
tblp(j, x) = tbl1(j)
Next j
End If

On Error GoTo 0
Next i

Range("A:D").ClearContents
Cells(1, 1).Resize(x, 4) = Application.Transpose(tblp)
End

Pozdrawiam wszystkich czytaczy :)

PS1. Mała poprawka w kodzie zasugerowana przez Wormsek'a :)
PS2. Parę kluczowych poprawek zasugerowanych przez szuszanę :)

Unik.Rek.rar

Pobierz Plik ściągnięto 835 raz(y) 9.6 KB

hurgadion · ExcelSpec Wersja: Win Office 2021 Posty: 2767

Można także uzyskać Unikaty usuwając duplikaty, np. za pomocą makra:

Kod:

Sub BezDup()
Dim i&, x As Range

For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
Set x = Range("A1:A" & i - 1)
If Not IsError(Application.Match(Cells(i, 1).Value, x, 0)) Then
Range("A" & i).Delete Shift:=xlUp
End If
Next i

Set x = Nothing
End Sub

Pozdrawiam.

BezDup.rar

Pobierz Plik ściągnięto 947 raz(y) 8.41 KB