İki Tarih Arası Veri Listeleme

denese · 15 Ağustos 2018

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.

Ömer BARAN · 15 Ağustos 2018

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

KMLZDMR · 15 Ağustos 2018

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.

denese · 16 Ağustos 2018

Ö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

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.

Ömer BARAN · 16 Ağustos 2018

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))

KMLZDMR · 16 Ağustos 2018

Sayın Ömer Baran üstadım teşekkür ederim. Çok güzel ve kısa çözüm.

Ömer BARAN · 16 Ağustos 2018

Eyvallah Sayın ÖZDEMİR, sağ olunuz.
İyi çalışmalar dilerim.

denese · 24 Ekim 2018

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.

YUSUF44 · 24 Ekim 2018

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

denese · 24 Ekim 2018

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"

YUSUF44 · 24 Ekim 2018

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.

denese · 24 Ekim 2018

Ekran görüntüsü aşağıda, dosya ekte yer alıyor Yusuf bey,

YUSUF44 · 24 Ekim 2018

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

denese · 24 Ekim 2018

Yusuf Bey, yardımlarınız için çok teşekkür ederim.

Saygılar

YUSUF44 · 24 Ekim 2018

İyi çalışmalar.

Haluk · 24 Ekim 2018

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.)

.

denese · 24 Ekim 2018

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.)

.

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

Haluk · 24 Ekim 2018

O zaman sorgulama yapilacak tabloda A1 hucresine niye sicil no yazdiniz?

.

denese · 24 Ekim 2018

Haluk' Alıntı:
O zaman sorgulama yapilacak tabloda A1 hucresine niye sicil no yazdiniz?

.

Haklısınız. Aslına uygun bir tablo kullanayım derken, sicil kriter alanı gereksiz olmuş.

YUSUF44 · 24 Ekim 2018

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.

İki Tarih Arası Veri Listeleme

denese

Ekli dosyalar

Ömer BARAN

Uzman

KMLZDMR

Ekli dosyalar

denese

Ömer BARAN

Uzman

KMLZDMR

Ömer BARAN

Uzman

denese

Ekli dosyalar

YUSUF44

Destek Ekibi

denese

YUSUF44

Destek Ekibi

denese

Ekli dosyalar

YUSUF44

Destek Ekibi

denese

YUSUF44

Destek Ekibi

Haluk

𐱅𐰇𐰼𐰚

Ekli dosyalar

denese

Haluk

𐱅𐰇𐰼𐰚

denese

YUSUF44

Destek Ekibi