VBA Tools

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
'OShon from VBATools.pl
If InStr(1, str, kwant) = 0 Then uniqueS_Count = 0: Exit Function
Dim y&, x&, part$, jest As Boolean, 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
'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

Poniżej następna możliwość wykorzystania unikatów i sortowania. Tym razem będzie to ze zdefiniowanego zakresu, wierszami przekopiowanie danych:

Sub Start()
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

Temat rozwojowy to też proszę śledzić zmiany.

(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.