Tolerans değerler arasında arama yapmak

[arda2002]

Merhaba arkadaşlar;
Elimde bulunan kalem sayısı çok fazla malzeme listesinde o anki ihtiyaca göre en, boy ya da ağırlık kriterlerinden birisini seçerek o anki ihtiyaca göre de değişken bir tolerans değeri vererek aradığım kriterlere uygun malzeme listesini çıkartmanın bir yolu var mı? Eğer böyle bir yöntem varsa ve de bana yardımı olabilirseniz çok minnettar kalağım. Şimdiden konuya ilgi gösterenlere çok teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.


Kullanılan kod; (Boş bir modüle uygulayın.)

Option Explicit
 
Sub LİSTELE()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, KRİTER As String, BİRİM As Double, TOLERANS As Double
    Dim İLK_DEĞER As Double, SON_DEĞER As Double, SATIR As Long, SÜTUN As Byte
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S1.Range("A11:F65536").ClearContents
    
    KRİTER = S1.Range("B3")
    
    If KRİTER = "" Then
        MsgBox "Lütfen bir kriter seçiniz !", vbCritical
        Exit Sub
    End If
    
    If KRİTER = "EN" Then
        SÜTUN = 2
    ElseIf KRİTER = "BOY" Then
        SÜTUN = 3
    ElseIf KRİTER = "AĞIRLIK" Then
        SÜTUN = 4
    End If
    
    BİRİM = S1.Range("C3")
    TOLERANS = S1.Range("D3")
    İLK_DEĞER = BİRİM - TOLERANS
    SON_DEĞER = BİRİM + TOLERANS
    SATIR = 11
    
    For X = 5 To S2.Range("A65536").End(3).Row
        If S2.Cells(X, SÜTUN) >= İLK_DEĞER And S2.Cells(X, SÜTUN) <= SON_DEĞER Then
            S1.Cells(SATIR, 1) = S2.Cells(X, 1)
            S1.Cells(SATIR, 2) = S2.Cells(X, 2)
            S1.Cells(SATIR, 3) = S2.Cells(X, 3)
            S1.Cells(SATIR, 4) = S2.Cells(X, 4)
            SATIR = SATIR + 1
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mancubus]

Korhan Bey elinize sağlık.

Bu kodu birden fazla kritere göre çalışacak şekilde geliştirmek mümkün müdür?

Bu konudaki örnek üzerinden gidersek...

Kriter 1 : Boy --- 15 --- 5
Kriter 2 : En ---- 40 --- 8

Bu 2 kriterin bir arada kullanımı ile ilgili olarak ta VE (her iki kritere de uyan tüm veriler) ile VEYA (kriterlerden herhangi birine uyan tüm veriler) seçenekleri eklenebilir mi?

 

[Korhan Ayhan]

Selamlar,

Sn. mancubus,

Ekteki örnek dosyayı incelermisiniz.


Kullanılan kod; (Boş bir modüle uygulayın.)

Option Explicit
 
Sub LİSTELE()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, ÖLÇÜT As String, SATIR As Long
    Dim KRİTER1 As String, BİRİM1 As Double, TOLERANS1 As Double
    Dim İLK_DEĞER1 As Double, SON_DEĞER1 As Double, SÜTUN1 As Byte
    Dim KRİTER2 As String, BİRİM2 As Double, TOLERANS2 As Double
    Dim İLK_DEĞER2 As Double, SON_DEĞER2 As Double, SÜTUN2 As Byte
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S1.Range("A11:F65536").ClearContents
    
    KRİTER1 = S1.Range("B3")
    KRİTER2 = S1.Range("B4")
    
    If KRİTER1 = "" Or KRİTER2 = "" Then
        MsgBox "İşleme devam edebilmeniz için en az bir kriter seçmelisiniz !", vbCritical
        Exit Sub
    End If
    
    If KRİTER1 = "EN" Then
        SÜTUN1 = 2
    ElseIf KRİTER1 = "BOY" Then
        SÜTUN1 = 3
    ElseIf KRİTER1 = "AĞIRLIK" Then
        SÜTUN1 = 4
    End If
    
    If KRİTER2 = "EN" Then
        SÜTUN2 = 2
    ElseIf KRİTER2 = "BOY" Then
        SÜTUN2 = 3
    ElseIf KRİTER2 = "AĞIRLIK" Then
        SÜTUN2 = 4
    End If
    
    BİRİM1 = S1.Range("C3")
    BİRİM2 = S1.Range("C4")
    TOLERANS1 = S1.Range("D3")
    TOLERANS2 = S1.Range("D4")
    
    İLK_DEĞER1 = BİRİM1 - TOLERANS1
    İLK_DEĞER2 = BİRİM2 - TOLERANS2
    SON_DEĞER1 = BİRİM1 + TOLERANS1
    SON_DEĞER2 = BİRİM2 + TOLERANS2
    
    ÖLÇÜT = S1.Range("E3")
    
    SATIR = 11
    
    For X = 5 To S2.Range("A65536").End(3).Row
        If KRİTER1 <> "" And KRİTER2 = "" Then
        
        If S2.Cells(X, SÜTUN1) >= İLK_DEĞER1 And S2.Cells(X, SÜTUN1) <= SON_DEĞER1 Then
            S1.Cells(SATIR, 1) = S2.Cells(X, 1)
            S1.Cells(SATIR, 2) = S2.Cells(X, 2)
            S1.Cells(SATIR, 3) = S2.Cells(X, 3)
            S1.Cells(SATIR, 4) = S2.Cells(X, 4)
            SATIR = SATIR + 1
        End If
    
        ElseIf KRİTER1 <> "" And KRİTER2 <> "" Then
    
        If ÖLÇÜT = "VE" Then
        If (S2.Cells(X, SÜTUN1) >= İLK_DEĞER1 And S2.Cells(X, SÜTUN1) <= SON_DEĞER1) And _
        (S2.Cells(X, SÜTUN2) >= İLK_DEĞER2 And S2.Cells(X, SÜTUN2) <= SON_DEĞER2) Then
            S1.Cells(SATIR, 1) = S2.Cells(X, 1)
            S1.Cells(SATIR, 2) = S2.Cells(X, 2)
            S1.Cells(SATIR, 3) = S2.Cells(X, 3)
            S1.Cells(SATIR, 4) = S2.Cells(X, 4)
            SATIR = SATIR + 1
        End If
    
        ElseIf ÖLÇÜT = "VEYA" Then
        If (S2.Cells(X, SÜTUN1) >= İLK_DEĞER1 And S2.Cells(X, SÜTUN1) <= SON_DEĞER1) Or _
        (S2.Cells(X, SÜTUN2) >= İLK_DEĞER2 And S2.Cells(X, SÜTUN2) <= SON_DEĞER2) Then
            S1.Cells(SATIR, 1) = S2.Cells(X, 1)
            S1.Cells(SATIR, 2) = S2.Cells(X, 2)
            S1.Cells(SATIR, 3) = S2.Cells(X, 3)
            S1.Cells(SATIR, 4) = S2.Cells(X, 4)
            SATIR = SATIR + 1
        End If
        End If
        
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[arda2002]

Korhan Bey,
Size nasıl teşekkür etsem azdır. Sürekli kafamı kurcalayan bir konu sizin sayenizde çözüme ulaştı. Ellerinize ve bilginize sağlık.

 

[mancubus]

cevap vermeyi atlamışım.

özür diler, çok teşekkür ederim.