TextBoxtaki Değere Göre Filtreleme

[Astalavista58]

Merhabalar herkese hayırlı haftasonu dilerim. Aşağıdaki kod ile TextBoxa yazacağım yılları(2018,2019 gibi) , "J" sütununda filtreleyip, istatistik sayfasına yapıştırıp, sayfayı masaüstüne kaydetsin istiyorum. Ancak TextBoxtaki değeri bir türlü filtreletemedim. Yardımcı olabilir misiniz

    Range("J1").Select
    Selection.AutoFilter Field:=10, Criteria1:="*" & tbYıl.Text & "*"
    Range("A2").CurrentRegion.Select
    Selection.Copy
    Sheets("İstatistik").Select
    Cells.Clear
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
       ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\HastaneyeSevkEdilenlerRAPOR.XLSX"
       ActiveWorkbook.Close
       Application.DisplayAlerts = True

 

[Muzaffer Ali]

Merhaba.

Butonun kodlarını aşağıdaki ile değiştirin.

Private Sub CommandButton1_Click()
    Sheets("İstatistik").Cells.Clear
    Range("A:K").AutoFilter Field:=10, Operator:=xlFilterValues, Criteria2:=Array(0, "1/1/" & tbYıl.Text)
    Range("A2").CurrentRegion.Copy
    Sheets("İstatistik").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A2").CurrentRegion.Copy Sheets("İstatistik").Range("A1")
    Application.DisplayAlerts = False
    Sheets("İstatistik").Copy
    ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\HastaneyeSevkEdilenlerRAPOR.xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

 

[Astalavista58]

Merhaba.

Butonun kodlarını aşağıdaki ile değiştirin.

Private Sub CommandButton1_Click()
    Sheets("İstatistik").Cells.Clear
    Range("A:K").AutoFilter Field:=10, Operator:=xlFilterValues, Criteria2:=Array(0, "1/1/" & tbYıl.Text)
    Range("A2").CurrentRegion.Copy
    Sheets("İstatistik").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A2").CurrentRegion.Copy Sheets("İstatistik").Range("A1")
    Application.DisplayAlerts = False
    Sheets("İstatistik").Copy
    ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\HastaneyeSevkEdilenlerRAPOR.xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

Sayın Muzaffer hocam ellerinize sağlık çok teşekkür ederim sizlerin sayesinde bu form sayesinde kendimi çok geliştirdim. Burda zaman ayırıp yardımcı olan herkesten Allah razı olsun.

Bir şey daha soracağım hocam bu kod her türlü işimi görüyüor, merakımdan ve ileride karşılaşabileceğim bir sorun olarak, Textboxa 2018,2019 şeklinde iki farklı yıl girip filtreleme sanşımız var mı, var ve uzun bir işlemse şayet hiç zahmet etmeyin, ama kısa bir işlemse müsait bir zamanınızda bilgilendirebilir misiniz

 

[Korhan Ayhan]

Deneyiniz.

Yılları yazarken arasına virgül ekleyiniz. (Örnek : 2018,2019,2022)

Private Sub CommandButton1_Click()
    Dim My_Connection As Object, My_Recordset As Object
    Dim S1 As Worksheet, S2 As Worksheet, X As Byte
    Dim My_Year As Variant, Year_Array As Variant
    
    Application.ScreenUpdating = False
    
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    Set S1 = Sheets("HastaneyeSevkEdilenler")
    Set S2 = Sheets("İstatistik")
 
    S2.Cells.Clear
 
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
     
    ReDim Year_Array(1 To 1)
     
    For Each My_Year In Split(Me.tbYıl, ",")
        X = X + 1
        ReDim Preserve Year_Array(1 To X)
        Year_Array(X) = "'" & My_Year & "'"
    Next
    
    Year_Array = Join(Year_Array, ",")
    
    Set My_Recordset = My_Connection.Execute("Select * From [" & S1.Name & "$] Where Year([BİRİMİNE YAZI]) In (" & Year_Array & ")")

    If Not My_Recordset.EOF Then
        S1.Range("A1:K1").Copy S2.Range("A1")
        S2.Range("A2").CopyFromRecordset My_Recordset
        S2.Range("J2:J" & S2.Rows.Count).NumberFormat = "dd.mm.yyyy"
        S2.Columns.AutoFit
        S2.Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Environ("UserProfile") & "\Desktop\HastaneyeSevkEdilenlerRAPOR.xlsx"
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
    End If

    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
  
    Application.ScreenUpdating = True
    
    If S2.Range("A1") = "" Then
        MsgBox "Uygun kayıt bulunamaadı!", vbExclamation
    Else
        MsgBox "İşleminiz tamamlanmıştır."
    End If
    
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[Astalavista58]

Sayın Hocam çok güzel bir şekilde çalışıyor, çok teşekkür ederim Allah razı olsun, rabbim gönlünüze göre versin

 

[Korhan Ayhan]

Küçük bir revize yaptım. Son halini deneyiniz.

 

[Astalavista58]

Küçük bir revize yaptım. Son halini deneyiniz.

Elinize sağlık hocam tekrardan teşekkür ederim, en son hali ile güncelledim

 

[Muzaffer Ali]

Aşağıdaki kodu ile olur. Alternatif olsun.
TextBox'a yazdığınız yıllar arasında (2022,2019,2028) şeklinde virgül olmalı

Private Sub CommandButton1_Click()
    Dim Yil As Integer
    Dim Yillar As Variant
    Dim Filtre() As Variant
    Dim Sira As Integer
   
    Yillar = Split(tbYıl.Text, ",")
    ReDim Filtre(((UBound(Yillar) + 1) * 2) - 1)
   
    For Yil = 0 To UBound(Yillar)
       
        Filtre(Sira) = 0
        Filtre(Sira + 1) = "1/1/" & Yillar(Yil)
        Sira = Sira + 2
    Next
   
    Sheets("İstatistik").Cells.Clear
    Range("A:K").AutoFilter Field:=10, Operator:=xlFilterValues, Criteria2:=Filtre
    Range("A2").CurrentRegion.Copy
    Sheets("İstatistik").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A2").CurrentRegion.Copy Sheets("İstatistik").Range("A1")
    Application.DisplayAlerts = False
    Sheets("İstatistik").Copy
    ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\HastaneyeSevkEdilenlerRAPOR.xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

 

[Astalavista58]

Aşağıdaki kodu ile olur. Alternatif olsun.
TextBox'a yazdığınız yıllar arasında (2022,2019,2028) şeklinde virgül olmalı

Private Sub CommandButton1_Click()
    Dim Yil As Integer
    Dim Yillar As Variant
    Dim Filtre() As Variant
    Dim Sira As Integer
  
    Yillar = Split(tbYıl.Text, ",")
    ReDim Filtre(((UBound(Yillar) + 1) * 2) - 1)
  
    For Yil = 0 To UBound(Yillar)
      
        Filtre(Sira) = 0
        Filtre(Sira + 1) = "1/1/" & Yillar(Yil)
        Sira = Sira + 2
    Next
  
    Sheets("İstatistik").Cells.Clear
    Range("A:K").AutoFilter Field:=10, Operator:=xlFilterValues, Criteria2:=Filtre
    Range("A2").CurrentRegion.Copy
    Sheets("İstatistik").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A2").CurrentRegion.Copy Sheets("İstatistik").Range("A1")
    Application.DisplayAlerts = False
    Sheets("İstatistik").Copy
    ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\HastaneyeSevkEdilenlerRAPOR.xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

Elinize sağlık sayın Hocam çok teşekkür ediyorum, Allah razı olsun

 

[Muzaffer Ali]

Allah senden de razı olsun, işlerine kolaylık versin. Selametle.