Birden fazla kritere göre otomatik süzme

[1903bjk]

arkadaşlar merhaba
elimde listedeki iki kritere göre makro ile süz işlemi yaparak süzülen verileri başka bir sayfaya kopyalamak istiyorum
ilgili dosya ektedir
mevcut yazılmış bir kod var ama sadece tarihe göre yapabiliyor
ben hem tarihe göre hem de ödeme tipine göre süzme yapmak istiyorum

yardımlarınızı rica ediyorum

saygılarımla

 

[1903bjk]

ARKADAŞLAR ÇOK MU ZOR ACABA BUNU YAPMAK
BİLEYİM Kİ ONA GÖRE BAŞKA PROJE ÜRETEYİM
BENDE MEVCUT KOD AŞAĞIDA
KATKILARINIZI BEKLİYORUM


Sub Düğme4_Tıklat()
Application.ScreenUpdating = False
Sheets("Sheet1").[A9:I65536].ClearContents
For Each a In Range("A8:A3000")
If a >= Range("B2").Value And a <= Range("C2").Value Then
a.Select
Selection.EntireRow.Select
Selection.Copy
Sheets("Sheet1").Select
Range("A8").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.PasteSpecial
End If
Sheets("Sheet3").Select
Next a
Application.CutCopyMode = False
MsgBox "İşlem Tamam"
Application.ScreenUpdating = True
End Sub

 

[Korhan Ayhan]

Selamlar,

A&#351;a&#287;&#305;daki kodu denermisiniz.

Sub RAPOR_AL()
    Application.ScreenUpdating = False
    Sheets("Sheet1").[A9:I65536].Clear
    Sheets("Sheet3").Select
    If Sheets("Sheet3").AutoFilterMode = True Then
    Range("A8:I8").Select
    Selection.AutoFilter
    End If
    Range("A8:I8").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:=CDate([B2])
    Selection.AutoFilter Field:=8, Criteria1:=[B4]
    If WorksheetFunction.Subtotal(2, [A9:A65536]) > 0 Then
    Range("A9:I" & [A65536].End(3).Row).Copy Sheets("Sheet1").[A9]
    Selection.AutoFilter Field:=1
    Selection.AutoFilter Field:=8
    [A1].Select
    Sheets("Sheet1").Select
    [A1].Select
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
    Else
    Selection.AutoFilter Field:=1
    Selection.AutoFilter Field:=8
    [A1].Select
    MsgBox "KRİTERLERE UYGUN VERİ BULUNAMAMIŞTIR !", vbExclamation
    End If
    Application.ScreenUpdating = True
End Sub

 

[1903bjk]

TeŞekkÜr

SAYIN COST CONTROL
MUHTEŞEMSİNİZ
ELİNİZE SAĞLIK
TAM İSTEDİĞİM GİBİ
BAŞKA SÖYLEYECEK BİRŞEY BULAMIYORUM

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub RAPOR_AL()
    Application.ScreenUpdating = False
    Sheets("Sheet1").[A9:I65536].Clear
    Sheets("Sheet3").Select
    If Sheets("Sheet3").AutoFilterMode = True Then
    Range("A8:I8").Select
    Selection.AutoFilter
    End If
    Range("A8:I8").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:=CDate([B2])
    Selection.AutoFilter Field:=8, Criteria1:=[B4]
    If WorksheetFunction.Subtotal(2, [A9:A65536]) > 0 Then
    Range("A9:I" & [A65536].End(3).Row).Copy Sheets("Sheet1").[A9]
    Selection.AutoFilter Field:=1
    Selection.AutoFilter Field:=8
    [A1].Select
    Sheets("Sheet1").Select
    [A1].Select
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
    Else
    Selection.AutoFilter Field:=1
    Selection.AutoFilter Field:=8
    [A1].Select
    MsgBox "KRİTERLERE UYGUN VERİ BULUNAMAMIŞTIR !", vbExclamation
    End If
    Application.ScreenUpdating = True
End Sub

 

[baydeniro]

Sayın Cost_Control yine çok yararlı bir kod yapmışsınız. Bu kodu ben kendi dosyama uyarladım. (Veriler A:C arasında ve kriterler D1 ile E1 de). Kod filtre işlemini istediğim gibi yapıyor ama Debug error hatası veriyor.

Sub RAPOR_AL()
Application.ScreenUpdating = False
Sheets("Sheet1").[A9:I65536].Clear
Sheets("Sheet1").Select
If Sheets("Sheet1").AutoFilterMode = True Then
Range("A1:C1").Select
Selection.AutoFilter
End If
Range("A1:C1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:=[D1]
Selection.AutoFilter Field:=3, Criteria1:=[E1]
If WorksheetFunction.Subtotal(2, [A2:A65536]) > 0 Then
Range("A1:C65536" & [A65536].End(3).Row).Copy Sheets("Sheet1").[A1]
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
[A1].Select
Sheets("Sheet1").Select
[A1].Select
MsgBox "ISLEMINIZ TAMAMLANMISTIR.", vbInformation
Else
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
[A1].Select
MsgBox "KRITERLERE UYGUN VERI BULUNAMAMISTIR !", vbExclamation
End If
Application.ScreenUpdating = True
End Sub