Število različnih elementov v obsegu

Pomoč pri izdelavi makrov
Odgovori
sonofagun
Prispevkov: 119
Pridružen: Če Mar 26, 2009 11:05 am

Število različnih elementov v obsegu

Odgovor Napisal/-a sonofagun »

Pozdravljeni.

Imam sledeč primer: v enem stolpcu so zapisani ponavljajoči se podatki (številke parcel - ene se ponovijo 10x, druge 6x, tretje 7x, ...). Ali obstaja kakšna funkcija, ki bi mi vrnila podatek o tem, koliko različnih parcel je v danem obsegu?

Hvala za odgovor.

Lp, Gregor
cedra
Prispevkov: 264
Pridružen: Po Jul 25, 2005 11:11 pm
Kraj: Kamnik

Re: Število različnih elementov v obsegu

Odgovor Napisal/-a cedra »

Rešitev za vas najdena že nekaj časa nazaj na spletu. Strani ne vem, je pa napisan avtor kode:

Koda: Izberi vse

Option Explicit
'***********Avtor kode***********
'   This example is based on a tip by J.G. Hussey,
'   published in "Visual Basic Programmer's Journal"

Sub Unikatni_zapisi()
    Dim AllCells As Range, Cell As Range
    Dim NoDupes As New Collection
    Dim i As Integer, j As Integer, x As Integer
    Dim Swap1, Swap2, Item
    x = 1
'   Izbrano območje A stolpec, do zadnje polne celice, ne sme biti vmes praznih, sicer ne bo najdeno vse
    Set AllCells = Range(Range("A1"), Range("A1").End(xlDown))
    
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell

    On Error GoTo 0
    'Povzetek iskanja zapiše v prvi dve celici stolpca G
    Cells(1, 7) = "Vseh zapisov: " & AllCells.Count
    Cells(2, 7) = "Unikatnih zapisov: " & NoDupes.Count
    
    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i
    
    'Unikatni zapisi so zapisani naraščajoče v stolpcu E
    For Each Item In NoDupes
        Cells(x, 5) = Item
        x = x + 1
    Next Item

End Sub
Mislim, da vam bo iz opomb, ki sem jih vpisal v kodo,stvar jasna... :)
lp,

cedra
sonofagun
Prispevkov: 119
Pridružen: Če Mar 26, 2009 11:05 am

Re: Število različnih elementov v obsegu

Odgovor Napisal/-a sonofagun »

Še celo več, kot sem rabil :-) Samo malo preuredim in to je to.
Hvala.

Lep pozdrav
Odgovori