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: 15-05-2011, 20:22   41. Unikaty

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 714 raz(y) 8.73 KB

_________________
miasto nauki
Ostatnio zmieniony przez hurgadion 22-03-2012, 22:04, w całości zmieniany 2 razy  
ID posta: 119315 Skopiuj do schowka
 
 
Trebor 
Excel Expert


Posty: 4680
Wysłany: 18-05-2011, 20:55   

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
_________________
Trebbor@wp.pl
ID posta: 119659 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Posty: 2098
Wysłany: 18-05-2011, 22:16   

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
_________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
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: 119674 Skopiuj do schowka
 
 
Trebor 
Excel Expert


Posty: 4680
Wysłany: 20-05-2011, 19:47   

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
_________________
Trebbor@wp.pl
ID posta: 119922 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Posty: 2098
Wysłany: 21-05-2011, 08:34   

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...
_________________
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
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: 119946 Skopiuj do schowka
 
 
OShon 
Excel Expert



Zaproszone osoby: 383
Wersja: Win Office 365
Posty: 8291
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
_________________
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: 122005 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 25-07-2011, 16:46   

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 551 raz(y) 8.75 KB

_________________
miasto nauki
ID posta: 125457 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 30-08-2011, 21:41   

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 677 raz(y) 9.07 KB

_________________
miasto nauki
ID posta: 128842 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 13-09-2011, 08:54   

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 482 raz(y) 6.11 KB

_________________
miasto nauki
ID posta: 130031 Skopiuj do schowka
 
 
mreck 
Excel Expert



Posty: 456
Wysłany: 13-09-2011, 19:32   

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 493 raz(y) 32.22 KB

_________________
mreck
ID posta: 130078 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 17-09-2011, 22:19   

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 434 raz(y) 7.68 KB

_________________
miasto nauki
Ostatnio zmieniony przez hurgadion 21-09-2011, 22:13, w całości zmieniany 1 raz  
ID posta: 130406 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 17-09-2011, 22:48   

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 423 raz(y) 9.11 KB

_________________
miasto nauki
ID posta: 130408 Skopiuj do schowka
 
 
OShon 
Excel Expert



Zaproszone osoby: 383
Wersja: Win Office 365
Posty: 8291
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ł
  1. Ilość unikatów dla wskazanego obszaru
  2. Ilość unikatów dla stringa
  3. Lista unikatów dla poprawności danych/lista
_________________
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: 131120 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 06-10-2011, 14:56   

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 426 raz(y) 9.6 KB

_________________
miasto nauki
ID posta: 132412 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Posty: 2447
Wysłany: 07-10-2011, 15:15   

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 527 raz(y) 8.41 KB

_________________
miasto nauki
ID posta: 132554 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