Excel VBA'da bir aralıktaki benzersiz değerlerin listesini nasıl alabilirim?

Question

VBA kullanarak bir aralıktaki benzersiz değerlerin listesini almak istiyorum. Google'daki çoğu örnek, VBA kullanan bir sütunda benzersiz değerler listesi hakkında konuşmaktadır.

Bir aralıktaki değerlerin listesini almak için bunu nasıl değiştireceğimi bilmiyorum. Örneğin

,

Currency Name 1 Name 2 Name 3 Name 4 Name 5 
SGD BGN DBS   
PHP PDSS     
KRW BGN    
CNY CBBT BGN   
IDA INPC     

My dizi gibi görünmelidir:

BGN, DBS, PDSS, CBBT and INPC. 

Bunu nasıl yapacağım? Biraz rehberliğe ihtiyacım var.

Answer 1

Aralık boyunca geçiş yapın, dizide eklemediyseniz, değerin dizide olup olmadığını kontrol edin.

Sub test() 
Dim Values() As Variant 
Values = GetUniqueVals(Selection) 
Dim i As Integer 
    For i = LBound(Values) To UBound(Values) 
     Debug.Print (Values(i)) 
    Next 

End Sub 

Function GetUniqueVals(ByRef Data As Range) As Variant() 
    Dim cell As Range 
    Dim uniqueValues() As Variant 
    ReDim uniqueValues(0) 

    For Each cell In Data 
     If Not IsEmpty(cell) Then 
      If Not InArray(uniqueValues, cell.Value) Then 
       If IsEmpty(uniqueValues(LBound(uniqueValues))) Then 
        uniqueValues(LBound(uniqueValues)) = cell.Value 
       Else 
        ReDim Preserve uniqueValues(UBound(uniqueValues) + 1) 
        uniqueValues(UBound(uniqueValues)) = cell.Value 
       End If 
      End If 
     End If 
    Next 
    GetUniqueVals = uniqueValues 
End Function 

Function InArray(ByRef SearchWithin() As Variant, ByVal SearchFor As Variant) As Boolean 
    Dim i As Integer 
    Dim matched As Boolean 'Default value of boolean is false, we make true only if we find a match 

    For i = LBound(SearchWithin) To UBound(SearchWithin) 
     If SearchWithin(i) = SearchFor Then matched = True 
    Next 

    InArray = matched 
End Function 

Answer 2

Basit bir VBA-Collection kullanır ve anahtar içeren öğeleri eklerim. Anahtar, öğenin kendisidir ve yinelenen anahtarlar olamaz çünkü koleksiyon benzersiz değerler içerecektir.

Not: Toplama için yinelenen anahtar ekleme arttığından, hata, çağrıyı toplama-hata-özgeçmiş-sonraki haline getirecek şekilde kaydırılır.

fonksiyonu GetUniqueValueskaynak menzil değerleri parametre olarak sahiptir ve tek kaynaktır menzil değerleri arasında VBA-Collection retuns. main yönteminde işlev çağrılır ve sonuç Çıkış Penceresine yazdırılır. HTH.

Option Explicit 

Sub main() 
    Dim uniques As Collection 
    Dim source As Range 

    Set source = ActiveSheet.Range("A2:F6") 
    Set uniques = GetUniqueValues(source.Value) 

    Dim it 
    For Each it In uniques 
     Debug.Print it 
    Next 
End Sub 

Public Function GetUniqueValues(ByVal values As Variant) As Collection 
    Dim result As Collection 
    Dim cellValue As Variant 
    Dim cellValueTrimmed As String 

    Set result = New Collection 
    Set GetUniqueValues = result 

    On Error Resume Next 

    For Each cellValue In values 
     cellValueTrimmed = Trim(cellValue) 
     If cellValueTrimmed = "" Then GoTo NextValue 
     result.Add cellValueTrimmed, cellValueTrimmed 
NextValue: 
    Next cellValue 

    On Error GoTo 0 
End Function 

Çıktı durumda

SGD 
PHP 
KRW 
CNY 
IDA 
BGN 
PDSS 
CBBT 
INPC 
DBS 
a 

---

yüzden:

Numune kaynak aralık böyle görünüyordu menzil menzili alanlardan ilk önce tüm alanların değerlerini alır.

Public Function GetSourceValues(ByVal sourceRange As Range) As Collection 
    Dim vals As VBA.Collection 
    Dim area As Range 
    Dim val As Variant 
    Set vals = New VBA.Collection 
    For Each area In sourceRange.Areas 
     For Each val In area.Value 
      If val <> "" Then _ 
       vals.Add val 
     Next val 
    Next area 
    Set GetSourceValues = vals 
End Function 

Kaynak türü artık Koleksiyon olduğunu ama sonra hepsi aynı çalışır: // msdn: Bir kesinlikle VBA tabanlı bir çözüm istiyorsanız

Dim uniques As Collection 
Dim source As Collection 

Set source = GetSourceValues(ActiveSheet.Range("A2:F6").SpecialCells(xlCellTypeVisible)) 
Set uniques = GetUniqueValues(source)