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
'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
'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()
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

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

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of Joanna Subik
Profile picture of Anorak
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