2 boyutlu dizide filtreleme

[tamer42]

Merhaba

Aşağıdaki kodda;

If UBound(Filter(Array_1, eleArr_1)) = 0 Then

satırında hata vermekte, bunu nasıl düzenleyebilirim?
ilginiz için şimdiden teşekkürler,

Sub Remove_All_Duplicated()
Dim Rng As Range
Dim Array_1
Dim Array_2()
Dim eleArr_1, x
x = 0

LR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "N").End(xlUp).Row
Set Rng = ActiveSheet.Range("N2:N" & LR)

Array_1 = Rng.Value

For Each eleArr_1 In Array_1
    If UBound(Filter(Array_1, eleArr_1)) = 0 Then
        ReDim Preserve Array_2(x)
        Array_2(x) = eleArr_1
        x = x + 1
    End If
Next

End Sub

 

[Asri]

Merhaba

Aşağıdaki kodda;

If UBound(Filter(Array_1, eleArr_1)) = 0 Then

satırında hata vermekte, bunu nasıl düzenleyebilirim?
ilginiz için şimdiden teşekkürler,

Sub Remove_All_Duplicated()
Dim Rng As Range
Dim Array_1
Dim Array_2()
Dim eleArr_1, x
x = 0

LR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "N").End(xlUp).Row
Set Rng = ActiveSheet.Range("N2:N" & LR)

Array_1 = Rng.Value

For Each eleArr_1 In Array_1
    If UBound(Filter(Array_1, eleArr_1)) = 0 Then
        ReDim Preserve Array_2(x)
        Array_2(x) = eleArr_1
        x = x + 1
    End If
Next

End Sub

Bu şekilde dener misiniz?

Array_1 = Application.Transpose(Rng.Value)

 

[tamer42]

Bu şekilde dener misiniz?

Array_1 = Application.Transpose(Rng.Value)

Asri Hocam öncelikle teşekkürler,

bu şekilde denedim, hata vermiyor, yalnız döngünü sonunda Array_2() dizisi boş geliyor.
burada amacım benzersiz değerleri Array_2() içine almak.

 

[Asri]

Bende sorun yok.

benzersiz.png dosyasını indir - download

benzersiz.png dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[tamer42]

Bende sorun yok.

benzersiz.png dosyasını indir - download

benzersiz.png dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Asri Hocam kodun çalışmasında sorun yok,
ekli görsele bakarsanız Array_2() dizisiinn içi boş durumda
iyi çalışmalar.

 

[Asri]

Benim gönderdiğim resimde altraki watches bölümünde Array_2 içeriğine baktınız mı?
Orada boş olmadığını görebilirsiniz.

 

[veyselemre]

Sub test()
    Dim Array_1, Array_2, elem
    Array_1 = Range("N2:N" & Cells(Rows.Count, "N").End(3).Row).Value
    With CreateObject("Scripting.Dictionary")
        For Each elem In Array_1
            .Item(elem) = .Item(elem) + 1
        Next elem

        For Each elem In .keys
            If .Item(elem) > 1 Then
                .Remove elem
            End If
        Next elem
        Array_2 = .keys
    End With
End Sub

Sub tekrarEtmeyenleriBul()
    Dim lr&, sn
    lr = Cells(Rows.Count, "N").End(3).Row
    sn = Filter(Evaluate("transpose(if(COUNTIF(N2:N" & lr & ",N2:N" & lr & ")=1,""_""&N2:N" & lr & ", """" ) )"), "_")
    sn = Split(Replace(Join(sn, ","), "_", ""), ",")
    MsgBox "Tekrarsızlar:" & Chr(10) & Join(sn, vbLf), vbExclamation, ""
End Sub

 

[tamer42]

Ekli dosyayı görüntüle 241027

Sub test()

ekli dosyayı kontrol edebilir misiniz,
neden olmuyor?
iyi çalışmalar.

 

[veyselemre]

Kodla tam olarak ne elde etmek istediğinizi söyleyebilir misiniz? Yazdığınız kod çalışıyor. Amacı dizide sadece 1 kez geçenleri bulmak. Tekrarsız liste çıkarmak değil. N sutunun altına xxxxx ekleyin deneyin.

 

[tamer42]

Kodla tam olarak ne elde etmek istediğinizi söyleyebilir misiniz? Yazdığınız kod çalışıyor. Amacı dizide sadece 1 kez geçenleri bulmak. Tekrarsız liste çıkarmak değil. N sutunun altına xxxxx ekleyin deneyin.

Veysel Hocam daha önce bahsetmiştim ama; N sutunda tekrar edilenleri kaldırmak, yani tekrar edenleri kaldırıp tekrarsız bir liste elde etmek,

excel' in yerleşik işlevi olan "Yenilenleri Kaldır" işleminin kod ile yapılması
teşekkürler,
iyi çalışmalar.

 

[veyselemre]

Sub test()
    Dim Array_2, elem
    With CreateObject("Scripting.Dictionary")
        For Each elem In Range("N2:N" & Cells(Rows.Count, "N").End(3).Row).Value
            .Item(elem) = Null
        Next elem
        Array_2 = .Keys
    End With
End Sub

 

[tamer42]

Sub test()
    Dim Array_2, elem
    With CreateObject("Scripting.Dictionary")
        For Each elem In Range("N2:N" & Cells(Rows.Count, "N").End(3).Row).Value
            .Item(elem) = Null
        Next elem
        Array_2 = .Keys
    End With
End Sub

Teşekkürler Veysel Hocam,
Ben de bu arada aşağıdaki i gibi çözüm üretmiştim.

Sub Remove_All_Duplicated()
Dim Rng As Range
Dim Array_1
Dim Array_2()
Dim eleArr_1
Dim a, x

x = 0

lr = ActiveSheet.Cells(ActiveSheet.Rows.Count, "N").End(xlUp).Row
Set Rng = ActiveSheet.Range("N2:N" & lr)

Array_1 = Application.Transpose(Rng.Value)

 ReDim Array_2(0)
 Array_2(0) = ActiveSheet.Range("N2")
 
 x = 1
 
For Each eleArr_1 In Array_1
a = UBound(Filter(Array_2, eleArr_1))
    If a = -1 Then
        ReDim Preserve Array_2(x)
        Array_2(x) = eleArr_1
        x = x + 1
    End If

Next

End Sub

 

[veyselemre]

Transpose, filter, preserve bunlar ağır çalışan fonksiyonlardır. Hız bakımından Dictionary ile boy ölçüşemez.

 

[Erdem Akdemir]

Dizilerle uğraşmadan ADO ile sorguda Distinct ifadesi ile kolayca yapılabilir.