Aynı sütunda makro ile çoklu filtreleme yapma

[mesudiye_052]

Merhabalar

Aynı sütunda(Örnek E sütunu) makro ile çoklu filtreleme yapmak istiyorum



kod

Sub cokluFiltre()

Dim ws As Worksheet
Dim rng As Range
Dim lr, i As Long
Dim col As Collection
Dim arr() As Variant
Dim durum As String

Set col = New Collection

lr = Cells(Rows.Count, "D").End(xlUp).Row




Do Until durum = "*"
    
    durum = Application.InputBox("Tük. ismi giriniz.", Type:=2)
    
    On Error Resume Next
    If durum <> "*" Then
        col.Add durum
    End If
    On Error GoTo 0
    
Loop
ReDim Preserve arr(1 To col.Count)

For i = 1 To col.Count
    arr(i) = col.Item(i)
Next i

arr = BubbleSort(arr)

For i = 1 To col.Count
   ActiveSheet.Range("$A$1:$Y$" & lr).AutoFilter Field:=5, Criteria1:=Array(arr(i)), Operator:=xlFilterValues
Next i

MsgBox "Tamam"



End Sub
Function BubbleSort(arr) As Variant
  Dim geçici As Variant
  Dim i As Long
  Dim j As Long
  Dim lngMin As Long
  Dim lngMax As Long
  
  lngMin = LBound(arr)
  lngMax = UBound(arr)
  For i = lngMin To lngMax - 1
    For j = i + 1 To lngMax
      If arr(i) > arr(j) Then
        geçici = arr(i)
        arr(i) = arr(j)
        arr(j) = geçici
      End If
    Next j
  Next i
  
BubbleSort = arr
End Function

Takıldığım kısım

ActiveSheet.Range("$A$1:$Y$" & lr).AutoFilter Field:=5, Criteria1:=Array(arr(i)), Operator:=xlFilterValues

Saygılarımla

 

[Korhan Ayhan]

Kriteriniz nedir?

 

[mesudiye_052]

Merhabalar

Kriter;
E sutunu Ad soyad

 

[Korhan Ayhan]

Çoklu derken işlemi nasıl yapmak istiyorsunuz?

 

[mesudiye_052]

Merhabalar;

E sütunda tüketici ismleri;
misal Ahmet, Sedat, Sezai vb yazdığımızda yazılan değerlerin aynı listede filtrelenmesini istiyorum

bir nevi gelişmiş filtre gibi

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Coklu_Filtre_Uygula()
    Dim Veri As Variant, Kriter As Variant, X As Integer, Say As Integer
    
    Veri = InputBox("Filtrelemek istediğiniz verileri aralarına virgül ekleyerek yazınız...", "Kriterlerinizi Giriniz...")
    
    If Veri = False Or Veri = "" Then Exit Sub
    
    Kriter = Split(Veri, ",")
    
    ReDim Liste(1 To 1)
    
    For X = LBound(Kriter) To UBound(Kriter)
        If Kriter(X) <> "" Then
            Say = Say + 1
            ReDim Preserve Liste(1 To Say)
            Liste(Say) = CStr(Kriter(X))
        End If
    Next
    
    If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData
    Range("A1:Y" & Rows.Count).AutoFilter 5, Liste, xlFilterValues

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mesudiye_052]

Merhaba Korhan AYHAN

Eline sağlık çok güzel olmuş

 

[mesudiye_052]

Merhaba Korhan AYHAN

kod 2 kritere kadar çalışıyor
fakat 2 den fazla olunca arama boş getiriyor

 

[Korhan Ayhan]

Ben denediğimde bahsettiğiniz sorunu yaşamadım.

 

[mesudiye_052]

Merhabalar;

Kod'da ufak bir değişiklik yapmışım bu sebepten 2 den fazla kritere göre süzmüyor

liste(Say) = CStr("*" & Kriter(X) & "*")

tam eşleşme ile beraber kısmi eşlem ile de yapılabilir mi

 

[Korhan Ayhan]

Filtre bölümü sizin yaptığınız düzenleme gibi çalışmıyor.

Eğer siz içerir mantığı ile çoklu filtreleme yapmak istiyorsanız kodun yapısını değiştirmek gerekecektir.

Deneyiniz.

Option Explicit

Sub Coklu_Filtre_Uygula()
    Dim Veri As Variant, Aranan As Variant, Kriter As Variant
    Dim X As Long, Son As Long, Y As Integer, Say As Integer
    
    Aranan = InputBox("Filtrelemek istediğiniz verileri aralarına virgül ekleyerek yazınız...", "Kriterlerinizi Giriniz...")
    
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    
    Son = Cells(Rows.Count, 5).End(3).Row
    If Son < 2 Then Son = 3
    
    Veri = Range("E2:E" & Son).Value
    
    Kriter = Split(Aranan, ",")
    
    ReDim Liste(1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = LBound(Kriter) To UBound(Kriter)
            If Kriter(Y) <> "" And UCase(Replace(Replace(Veri(X, 1), "ı", "I"), "i", "İ")) Like "*" & _
                UCase(Replace(Replace(Kriter(Y), "ı", "I"), "i", "İ")) & "*" Then
                Say = Say + 1
                ReDim Preserve Liste(1 To Say)
                Liste(Say) = CStr(Veri(X, 1))
            End If
        Next
    Next
    
    Range("A1:Y" & Rows.Count).AutoFilter 5, Liste, xlFilterValues

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mesudiye_052]

Merhaba Korhan AYHAN

Tam istediğim gibi

çok teşekkür ederim.