VBATools

Unikaty dla zakresu lub stringa

by 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

XL_AZiUnikaty_lista_poprawnosci2

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

XL_Kopia_Unikatow_w_wierszu

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.
:, , , , ,

2 Comments for this entry

Leave a Reply