Çoklu kritere göre filitre

[BYSERTTAS]

Herkesin Mubarek Ramazan Bayramını Tebrik ediyorum. Rabbim nice bayramlara saglıklı ve imanlı ulaşmamızı nasip eylesin insallah.

Ekli Dosyda anlatmaya çalıştım. coklu krıtere gore suzme yapıp listbox a almayı ogrenmeye çalışıyorum. tarihe gore filtrelemeyi yaptım.(Forumdan copy-paste yontemi ile) ek krıterlerı uygulayamadım. yardımcı olursanız sevinirim.

 

[BYSERTTAS]

Arkadaşlar yardımcı olacak kimseyokmu bir yardım lütfen

 

[dost]

Merhaba,

Aşağıdaki kodları denersiniz.

Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim lastRow, i As Long
Dim FilteredRange As Range
Dim FirmCrtr As String
Dim MyRng

On Error Resume Next

Application.ScreenUpdating = False

ActiveSheet.ShowAllData

If TextBox2.Value <> "" And TextBox1.Value = "" Then MsgBox "TextBox1 boş geçilemez !!!": TextBox1.SetFocus: Exit Sub
If TextBox1.Value <> "" And TextBox2.Value = "" Then MsgBox "TextBox2 boş geçilemez !!!": TextBox2.SetFocus: Exit Sub
If TextBox1.Value = "" And TextBox2.Value = "" Then
    TextBox1.Value = Format(CDate(WorksheetFunction.Min(s1.Columns(1))), "dd.mm.yyyy")
    TextBox2.Value = Format(CDate(WorksheetFunction.Max(s1.Columns(1))), "dd.mm.yyyy")
End If

FirmCrtr = IIf(FirmaAdı = "", "*", FirmaAdı)

Set s1 = Sheets("Sayfa1")
lastRow = s1.Range("A" & s1.Rows.Count).End(xlUp).Row

With s1.UsedRange
    .AutoFilter Field:=1, Criteria1:=">=" & CLng(CDate(TextBox1.Value)), Operator:=xlAnd, Criteria2:="<=" & CLng(CDate(TextBox2.Value)), Operator:=xlFilterValues
    .AutoFilter Field:=2, Criteria1:=FirmCrtr, Operator:=xlFilterValues
End With

Set FilteredRange = s1.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)

FilteredRange.Copy s1.Range("Z1")
MyRng = s1.Range("Z1").CurrentRegion

ListBox1.ColumnCount = 15
ListBox1.ColumnHeads = False
ListBox1.Clear
ListBox1.List = MyRng

For i = 0 To ListBox1.ListCount
    ListBox1.List(i, 0) = Format(ListBox1.List(i, 0), "dd.mm.yyyy")
Next i

TextBox3 = Format(WorksheetFunction.Subtotal(9, s1.Columns(4)), "Currency")
TextBox4 = Format(WorksheetFunction.Subtotal(9, s1.Columns(5)), "Currency")

ActiveSheet.ShowAllData
s1.Range("Z1").CurrentRegion.Clear

Set s1 = Nothing:  Set FilteredRange = Nothing

Application.ScreenUpdating = True

End Sub


Private Sub UserForm_Initialize()
Dim oDict As Object
Dim s1 As Worksheet
Dim MyRng As Range
Dim lastRow As Long

Set s1 = Sheets("Sayfa1")
lastRow = s1.Range("B" & s1.Rows.Count).End(xlUp).Row
Set oDict = CreateObject("Scripting.Dictionary")

For Each MyRng In s1.Range("B2:B" & lastRow)
    If Not oDict.exists(MyRng.Value) Then
        oDict.Add MyRng.Value, 0
        FirmaAdı.AddItem MyRng.Value
    End If
Next MyRng

Set s1 = Nothing:  Set oDict = Nothing

End Sub

 

[BYSERTTAS]

Merhaba,

Aşağıdaki kodları denersiniz.

Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim lastRow, i As Long
Dim FilteredRange As Range
Dim FirmCrtr As String
Dim MyRng

On Error Resume Next

Application.ScreenUpdating = False

ActiveSheet.ShowAllData

If TextBox2.Value <> "" And TextBox1.Value = "" Then MsgBox "TextBox1 boş geçilemez !!!": TextBox1.SetFocus: Exit Sub
If TextBox1.Value <> "" And TextBox2.Value = "" Then MsgBox "TextBox2 boş geçilemez !!!": TextBox2.SetFocus: Exit Sub
If TextBox1.Value = "" And TextBox2.Value = "" Then
    TextBox1.Value = Format(CDate(WorksheetFunction.Min(s1.Columns(1))), "dd.mm.yyyy")
    TextBox2.Value = Format(CDate(WorksheetFunction.Max(s1.Columns(1))), "dd.mm.yyyy")
End If

FirmCrtr = IIf(FirmaAdı = "", "*", FirmaAdı)

Set s1 = Sheets("Sayfa1")
lastRow = s1.Range("A" & s1.Rows.Count).End(xlUp).Row

With s1.UsedRange
    .AutoFilter Field:=1, Criteria1:=">=" & CLng(CDate(TextBox1.Value)), Operator:=xlAnd, Criteria2:="<=" & CLng(CDate(TextBox2.Value)), Operator:=xlFilterValues
    .AutoFilter Field:=2, Criteria1:=FirmCrtr, Operator:=xlFilterValues
End With

Set FilteredRange = s1.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)

FilteredRange.Copy s1.Range("Z1")
MyRng = s1.Range("Z1").CurrentRegion

ListBox1.ColumnCount = 15
ListBox1.ColumnHeads = False
ListBox1.Clear
ListBox1.List = MyRng

For i = 0 To ListBox1.ListCount
    ListBox1.List(i, 0) = Format(ListBox1.List(i, 0), "dd.mm.yyyy")
Next i

TextBox3 = Format(WorksheetFunction.Subtotal(9, s1.Columns(4)), "Currency")
TextBox4 = Format(WorksheetFunction.Subtotal(9, s1.Columns(5)), "Currency")

ActiveSheet.ShowAllData
s1.Range("Z1").CurrentRegion.Clear

Set s1 = Nothing:  Set FilteredRange = Nothing

Application.ScreenUpdating = True

End Sub


Private Sub UserForm_Initialize()
Dim oDict As Object
Dim s1 As Worksheet
Dim MyRng As Range
Dim lastRow As Long

Set s1 = Sheets("Sayfa1")
lastRow = s1.Range("B" & s1.Rows.Count).End(xlUp).Row
Set oDict = CreateObject("Scripting.Dictionary")

For Each MyRng In s1.Range("B2:B" & lastRow)
    If Not oDict.exists(MyRng.Value) Then
        oDict.Add MyRng.Value, 0
        FirmaAdı.AddItem MyRng.Value
    End If
Next MyRng

Set s1 = Nothing:  Set oDict = Nothing

End Sub

Çok Özür Dilerim. Geç Yanıtladım ama İşlemi Doğru Şekilde Yapıyor. tam istediğim gibi ellerinize sağlık. Şükranlarımı sunuyorum.