Unikaty dla zakresu lub stringa
by vbatools on Sep.23, 2011, under Excel, Porady
Lista unikatów przydaje się w wielu sytuacjach, np.: dla dla wyboru elementów w formularzach, listach poprawności lub wyznaczenie skali zbioru.
Jednym z najprostszych sposobów to utworzenie tabli przestawnej, która w swoim mechanizmie zlicza elementy licznika. Jednakże w programowaniu dodatku tworzenie lub tworzeniu mechanizmu w pliku utrzymywanie tabeli przestawnej w większości rzutuje na efektywności działania rozwiązania. Poniżej przytaczam funkcje, które zostały napisane specjalnie do opisanych celów.
Funkcja ilości unikatów dla obszaru.
'Debug.Print uniqueR2_Count(Range("b3:m3"), True) Function uniqueR2_Count(r As Range, Optional no_empty_cells As Boolean) As Long 'MVP OShon from VBATools.pl Dim el As Range Dim tabunik As New Collection For Each el In r If no_empty_cells = True And Len(Trim(el.value)) = 0 Then GoTo opusc On Error Resume Next tabunik.Add el.value, CStr(el.value) On Error GoTo 0 opusc: Next el uniqueR2_Count = tabunik.Count End Function
Funkcja ilości unikatów dla stringa.
'Debug.Print uniqueS2_Count("a,b,c,d, ,,d", ",", True) Function uniqueS2_Count(str As String, kwant As String, _ Optional no_space As Boolean) As Long 'MVP OShon from VBATools.pl If InStr(1, str, kwant) = 0 Then uniqueS2_Count = 0: Exit Function Dim y&, part$, tabunik As New Collection If no_space = True Then str = Replace(str, " ", "") For y = 0 To UBound(Split(str, kwant)) part = Split(str, kwant)(y) On Error Resume Next If Len(part) > 0 Then tabunik.Add part, CStr(part) On Error GoTo 0 Next y uniqueS2_Count = tabunik.Count End Function
Funkcja unikalnych elementów do wykorzystania w liście poprawności danych.
Dodatkowo w porządku posortowanym A-Z:
Sub Dodaj_liste_w_PoprawnosciDanych() With Range("O8").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=uniqueL_Count(Range("a4:u4"), True) .InCellDropdown = True .ShowInput = True .ShowError = True End With End Sub Function uniqueL_Count(r As Range, Optional no_empty_cells As Boolean) As String 'MVP OShon from VBATools.pl Dim el As Range, x&, tabunik As New Collection, lista$, i&, j&, swap1, swap2 For Each el In r If no_empty_cells = True And Len(Trim(el.Value)) = 0 Then GoTo opusc On Error Resume Next tabunik.Add el.Value, CStr(el.Value) On Error GoTo 0 opusc: Next el For i = 1 To tabunik.Count - 1 For j = i + 1 To tabunik.Count If tabunik(i) > tabunik(j) Then swap1 = tabunik(i) swap2 = tabunik(j) tabunik.Add swap1, before:=j tabunik.Add swap2, before:=i tabunik.Remove i + 1 tabunik.Remove j + 1 End If Next j Next i For x = 1 To tabunik.Count lista = lista & "," & tabunik.Item(x) Next x uniqueL_Count = lista End Function
Rys.1 Unikaty dodane jako lista poprawności
Poniżej następna możliwość wykorzystania unikatów i sortowania. Tym razem będzie to ze zdefiniowanego zakresu, wierszami przekopiowanie danych:
Sub Start() 'MVP OShon from VBATools.pl Dim x&, max_row&: max_row = Cells(Rows.Count, "A").End(xlUp).Row For x = 1 To max_row Call kopiowanie_unikatow(Range(Cells(x, 1), Cells(x, 11)), 15) Next x End Sub Sub kopiowanie_unikatow(obszar_wiersz As Range, docelowa&) Dim el As Range, tabunik As New Collection, i&, j&, swap1, swap2 For Each el In obszar_wiersz On Error Resume Next tabunik.Add el.Value, CStr(el.Value) On Error GoTo 0 Next el For i = 1 To tabunik.Count - 1 For j = i + 1 To tabunik.Count If tabunik(i) > tabunik(j) Then swap1 = tabunik(i) swap2 = tabunik(j) tabunik.Add swap1, before:=j tabunik.Add swap2, before:=i tabunik.Remove i + 1 tabunik.Remove j + 1 End If Next j Next i For i = 1 To tabunik.Count Cells(obszar_wiersz.Row, docelowa).Offset(, i - 1) = tabunik(i) Next i End Sub
Rys.2 Unikaty dla list w wierszach
Unikaty dla dwóch zbiorów. Wynik oddzielany splitem:
Function Unikaty2zakr(rng1 As Range, rng2 As Range) As String 'MVP OShon from VBATools.pl Dim tbl1(): tbl1() = rng1.Value Dim tbl2(): tbl2() = rng2.Value Dim maxG&: maxG = WorksheetFunction.Max(UBound(tbl1), UBound(tbl2)) Dim dic1 As Object: Set dic1 = CreateObject("Scripting.Dictionary") Dim dic2 As Object: Set dic2 = CreateObject("Scripting.Dictionary") Dim dicRem As Object: Set dicRem = CreateObject("Scripting.Dictionary") Dim x&, s1$, s2$, el On Error Resume Next For x = 1 To maxG If dic2.exists(tbl1(x, 1)) = False Then _ dic1.Add tbl1(x, 1), CStr(tbl1(x, 1)) Else _ dicRem.Add tbl1(x, 1), CStr(tbl1(x, 1)) If dic1.exists(tbl2(x, 1)) = False Then _ dic2.Add tbl2(x, 1), CStr(tbl2(x, 1)) Else _ dicRem.Add tbl2(x, 1), CStr(tbl2(x, 1)) If dicRem.exists(tbl1(x, 1)) = True Then dic1.Remove tbl1(x, 1): dic2.Remove tbl1(x, 1) If dicRem.exists(tbl2(x, 1)) = True Then dic1.Remove tbl2(x, 1): dic2.Remove tbl2(x, 1) Next On Error GoTo 0 For Each el In dic1 s1 = s1 & el & "," Next For Each el In dic2 s2 = s2 & el & "," Next Unikaty2zakr = s1 & "|" & s2 End Function
Rys.3 Unikaty dwóch zbiorów
Temat rozwojowy to też proszę śledzić zmiany.
Powstał dodatek “za drobne” do tworzenia listy unikatów z zdefiniowanego obszaru. Chętnych zapraszam.
(c) Shon Oskar – www.VBATools.pl
Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.
May 23rd, 2013 on 10:30
Oskar, w funkcji uniqueS2_Count w lini:
If InStr(1, str, kwant) = 0 Then uniqueS_Count = 0: Exit Function
z nazwy funkcji uciekła Ci dwójka – uniqueS_Count.
😉
Funkcyjki przydatne – super.
Hejka.
May 23rd, 2013 on 11:34
Dzięki – poprawiłem