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

Ostatnio zalogowani:

Profile picture of vbatools
Profile picture of Anorak
Profile picture of Joanna Subik
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała