• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İki Tarih Arası Veri Listeleme

D

denese

Katılım
17 Mart 2011
Mesajlar
441
Excel Vers. ve Dili
Office 2019
Herkese merhaba,

İki tarih aralığına ve sicil numarasına göre eşleşen verileri buton yardımıyla listelemek istiyorum. Detaylı açıklama örnek dosya üzerinde yer alıyor. Yardımcı olabilecek ustadlarıma şimdiden teşekkür ederim.

Kolaylıklar dilerim.
 

Ekli dosyalar

Merhaba.

Aşağıdaki kod'u sayfaya eklediğiniz düğme ile ilişkilendirin.
A2 boş ise tüm siciller, B2 boş ve C2 dolu ise C2'den küçük tarihler, B dolu ve C2 boş ise B2'den büyük olanlar,
B2 ve C2 dolu ise iki tarih arasındakiler listelenir.
Kod: 
Sub KRITERLI_LISTELE()
Set d = Sheets("Data"): Set l = Sheets("Listele")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    If l.[B2] <> "" And l.[C2] <> "" And l.[C2] < l.[B2] Then
        MsgBox "Başlangıç tarihi, bitiş tarihinden küçük olmalıdır."
        Exit Sub
    End If
    
    If l.[A2] = "" Then
        d.Range("A1:K1").AutoFilter Field:=1
            Else
                d.Range("A1:K1").AutoFilter Field:=1, Criteria1:=l.[A2]
                    End If
                        If l.[B2] = "" Then
                            d.Range("A1:K1").AutoFilter Field:=7
                                Else
                            d.Range("A1:K1").AutoFilter Field:=7, Criteria1:=">=" & CLng(l.[B2])
                        End If
                    If l.[C2] = "" Then
                d.Range("A1:K1").AutoFilter Field:=8
            Else
        d.Range("A1:K1").AutoFilter Field:=8, Criteria1:="<=" & CLng(l.[C2])
    End If
    
    If d.Cells(Rows.Count, 1).End(3).Row > 1 Then
        l.Range("A4:K" & l.Cells(Rows.Count, 1).End(3).Row).Clear
        d.Range("A1").CurrentRegion.Copy l.[A4]
        d.Range("A1:K1").AutoFilter Field:=1
        d.Range("A1:K1").AutoFilter Field:=7
        d.Range("A1:K1").AutoFilter Field:=8
        mesaj = l.Cells(Rows.Count, 1).End(3).Row - 4 & " adet kayıt listelendi."
    Else
        mesaj = "Aranan kriterlere uygun veri yok."
    End If
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox mesaj
End Sub
 
Merhaba Sayın Ömer BARAN üstadım...
konuyu formüllerle yardımcı sütun kullanarak yapmaya çalışıyordum. Yapamadım.... yarım hali ile göndermek isterim. Mümkünse formülle yapmanız mümkü mü?

Teşekkürler.
 

Ekli dosyalar

Ömer BARAN' Alıntı:
Merhaba.

Aşağıdaki kod'u sayfaya eklediğiniz düğme ile ilişkilendirin.
A2 boş ise tüm siciller, B2 boş ve C2 dolu ise C2'den küçük tarihler, B dolu ve C2 boş ise B2'den büyük olanlar,
B2 ve C2 dolu ise iki tarih arasındakiler listelenir.
Kod: 
Sub KRITERLI_LISTELE()
Set d = Sheets("Data"): Set l = Sheets("Listele")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    If l.[B2] <> "" And l.[C2] <> "" And l.[C2] < l.[B2] Then
        MsgBox "Başlangıç tarihi, bitiş tarihinden küçük olmalıdır."
        Exit Sub
    End If
   
    If l.[A2] = "" Then
        d.Range("A1:K1").AutoFilter Field:=1
            Else
                d.Range("A1:K1").AutoFilter Field:=1, Criteria1:=l.[A2]
                    End If
                        If l.[B2] = "" Then
                            d.Range("A1:K1").AutoFilter Field:=7
                                Else
                            d.Range("A1:K1").AutoFilter Field:=7, Criteria1:=">=" & CLng(l.[B2])
                        End If
                    If l.[C2] = "" Then
                d.Range("A1:K1").AutoFilter Field:=8
            Else
        d.Range("A1:K1").AutoFilter Field:=8, Criteria1:="<=" & CLng(l.[C2])
    End If
   
    If d.Cells(Rows.Count, 1).End(3).Row > 1 Then
        l.Range("A4:K" & l.Cells(Rows.Count, 1).End(3).Row).Clear
        d.Range("A1").CurrentRegion.Copy l.[A4]
        d.Range("A1:K1").AutoFilter Field:=1
        d.Range("A1:K1").AutoFilter Field:=7
        d.Range("A1:K1").AutoFilter Field:=8
        mesaj = l.Cells(Rows.Count, 1).End(3).Row - 4 & " adet kayıt listelendi."
    Else
        mesaj = "Aranan kriterlere uygun veri yok."
    End If
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox mesaj
End Sub
Genişletmek için tıkla ...
Merhaba Sayın Ömer BARAN,

Çalışmalarımda emeğiniz çok büyük. Forumdaki bir çok konuda detaylı, açıklayıcı ve eğitici paylaşımlarınızdan defalarca faydalandım. Desteğinizi esirgemediğiniz için tekrar tekrar teşekkür ederim.

Saygılar, selamlar.
 
Sayın ÖZDEMİR, aşağıdaki şekilde olur.

-- Data sayfası K2 hücresine (liste boyunca kopyalanacak)
Formül, Listeleme sayfasına aktarılacak, koşullara uyan satırlara sıra numarası verilmesini sağlar.
Formüldeki YADA kısımları, sırasıyla A, G ve H sütunundaki koşulları kontrol eder, VE kısmı ise bu koşulların tümünün birden sağlanıp sağlanmadığını kontrol eder.
Rich (BB code): 
=EĞER(
VE(
YADA(VE(Listele!$A$2<>"";Listele!$A$2=$A2);Listele!$A$2="");
YADA(VE(Listele!$B$2<>"";Listele!$B$2<=$G2);Listele!$B$2="");
YADA(VE(Listele!$C$2<>"";Listele!$C$2>=$H2);Listele!$C$2="")
);
MAK(Data!$K$1:K1)+1;"")
-- Listele sayfası A5 hücresine (sağa ve aşağı doğru, boş sonuç elde edinceye kadar kopyalanacak)
Data sayfası K sütununa uygulanan formül sonuçlarına (sıra numarası) göre veriler Listeleme sayfasına çağrılmış olur.
Rich (BB code): 
=EĞER(SATIR(A1)>MAK(Data!$K$2:$K$11658);"";KAYDIR(Data!$A$1;KAÇINCI(SATIR(A1);Data!$K$2:$K$11658;0);SÜTUN(A1)-1))
 
Sayın Ömer Baran üstadım teşekkür ederim. Çok güzel ve kısa çözüm.
 
Eyvallah Sayın ÖZDEMİR, sağ olunuz.
İyi çalışmalar dilerim.
 
Merhaba değerli hocalarım,

Kriterli listeleme konusunda benzer bir çalışmaya daha ihtiyaç duydum. Detayları ekli dosya üzerinde belittim.
Tekrar yardımlarınızı rica ediyorum.

İyi günler dilerim.
 

Ekli dosyalar

Aşağıdaki kodları bir modüle kopyalayıp deneyin. Verileriniz çok olduğundan sonuç almak biraz uzun sürebilir:

Kod: 
Sub sonizin()
Set s1 = Sheets("Data")
Set s2 = Sheets("Listele")
son = s1.Cells(Rows.Count, "A").End(3).Row
baş = s2.[B2]
bit = s2.[C2]

For i = 2 To son
    If s1.Cells(i, "G") >= baş And s1.Cells(i, "G") <= bit Then
        yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
        If WorksheetFunction.CountIf(s2.Range("A4:A" & yeni), s1.Cells(i, "A")) > 0 Then
            If WorksheetFunction.VLookup(s1.Cells(i, "A"), s2.Range("A5:G" & yeni), 7, 0) < s1.Cells(i, "G") Then
                sıra = WorksheetFunction.Match(s1.Cells(i, "A"), s2.Range("A5:A" & yeni), 0) + 4
                s1.Range("A" & i & ":J" & i).Copy: s2.Cells(sıra, "A").PasteSpecial Paste:=xlValues
            End If
        Else
            s1.Range("A" & i & ":J" & i).Copy: s2.Cells(yeni, "A").PasteSpecial Paste:=xlValues
        End If
    End If
Next
s2.Range("G5:I" & yeni).NumberFormat = "dd/mm/yyyy"
MsgBox "İşlem Tamamlandı"
End Sub
 
Merhaba Yusuf44

Kod ilk seferinde çalıştı. Fakat tarih kriterindeki ilk tarihi değiştirdiğimizde aşağıdaki kodda hata veriyor.

Kod: 
s2.Range("G5:I" & yeni).NumberFormat = "dd/mm/yyyy"
 
Hem ilk tarihi hem de sonra tarihi değiştirdim, herhangi bir hata vermedi. Ayrıca hata verdiğini belirttiğiniz satırla ilk tarih arasında bir ilişki bulunmuyor. O satır G, H, I sütunlarındaki tarihlerin biçimini değiştiriyor sadece.

Dosyayı hata verdiği haliyle yükleyin inceleyelim.
 
Ekran görüntüsü aşağıda, dosya ekte yer alıyor Yusuf bey,


Adsız.jpg
 

Ekli dosyalar

O hatayı herhangi bir veri listelemediğinde veriyor, çünkü yeni değişkenine herhangi bir değer atanmamış oluyor. Aşağıdaki gibi kullanabilirsiniz:

Kod: 
Sub sonizin()
Set s1 = Sheets("Data")
Set s2 = Sheets("Listele")
son = s1.Cells(Rows.Count, "A").End(3).Row
baş = s2.[B2]
bit = s2.[C2]

For i = 2 To son
    If s1.Cells(i, "G") >= baş And s1.Cells(i, "G") <= bit Then
        yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, "A").End(3).Row + 1, 5)
        If WorksheetFunction.CountIf(s2.Range("A4:A" & yeni), s1.Cells(i, "A")) > 0 Then
            If WorksheetFunction.VLookup(s1.Cells(i, "A"), s2.Range("A5:G" & yeni), 7, 0) < s1.Cells(i, "G") Then
                sıra = WorksheetFunction.Match(s1.Cells(i, "A"), s2.Range("A5:A" & yeni), 0) + 4
                s1.Range("A" & i & ":J" & i).Copy: s2.Cells(sıra, "A").PasteSpecial Paste:=xlValues
            End If
        Else
            s1.Range("A" & i & ":J" & i).Copy: s2.Cells(yeni, "A").PasteSpecial Paste:=xlValues
        End If
    End If
Next
If s2.[A5] <> "" Then
    s2.Range("G5:I" & yeni).NumberFormat = "dd/mm/yyyy"
    MsgBox "İşlem Tamamlandı"
Else
    MsgBox "Belirtilen tarihler arasında herhangi bir izin kaydı bulunamadı"
End If
End Sub
 
Yusuf Bey, yardımlarınız için çok teşekkür ederim.

Saygılar
 
İyi çalışmalar.
 
Ben anladığım kadarıyla hazırladığım alternatif dosyayı ekledim.

(A1 hücresinde sicil no'su yazan kişinin kullandığı en son izne ait bilgiler A5:J5 hücrelerine yazılır.)

.
 

Ekli dosyalar

Son düzenleme:
Haluk' Alıntı:
Ben anladığım kadarıyla hazırladığım alternatif dosyayı ekledim.

(A1 hücresinde sicil no'su yazan kişinin kullandığı en son izne ait bilgiler A5:J5 hücrelerine yazılır.)

.
Genişletmek için tıkla ...
Merhaba Haluk Bey,

Bu kod ile herhangi bir kişinin, belirtilen tarih aralığında kullandığı en son izni bulabiliyoruz. Elde etmek istediğim sonuç şuydu, Yusuf Bey' in çalışmasındaki gibi; belirtilen tarih aralığında izin kullanan herkesin, kullandıkları en son izinleri listelemek. Desteğiniz için teşekkür ederim.

İyi çalışmalar
 
Son düzenleme:
O zaman sorgulama yapilacak tabloda A1 hucresine niye sicil no yazdiniz?

.
 
O sicil numarası sanıyorum dosyada mevcut diğer makroda belirtilen kişinin o tarihler arasındaki tüm izinlerini listelemek için kullanılıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst