İki Tarih Arası Veri Listeleme

[denese]

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.

Doğrudur Yusuf Bey. Asıl dosyada birden fazla makro uygulaması mevcut.

 

[Haluk]

Yusuf Beyin kodu biraz daha hızlı ama, önerdiğim SQL alternatifinin yarım kalmaması için dosyayı revize ettim.

Not: Dosya revize edildi .... (Saat 19:56)

.

 

[denese]

Yusuf Beyin kodu biraz daha hızlı ama, önerdiğim SQL alternatifinin yarım kalmaması için dosyayı revize ettim.

.

Desteğiniz için çok teşekkür ederim Haluk Bey.

Saygılar.

 

[lider22]

Bununla ilgili bir video hazırlamıştım.
Linkten izleyebilirsiniz.
http://bymmb.com/excel-makro-ile-tablo-ozetleme/

 

[Haluk]

Bununla ilgili bir video hazırlamıştım.
Linkten izleyebilirsiniz.

Konuyu ben de başta tam anlamamıştım ancak, şunu söyleyebilirim ki; konu tam olarak önerdiğiniz dosyadaki gibi değil.

Orjinal soruyu sizin dosyanıza göre uyarlarsak; satış elemanlarının belirli 2 tarih arasında (örneğin, 03.02.2014 - 05.02.2014) en son tarihte o güne ait yaptıkları satış adetlerinin listelenmesi .... şeklinde özetleyebiliriz.

.

 

[Ziynettin]

Alternatif,

Dizi yöntemi ile yapılan çalışma.

Sub test()
Dim t1 As Date, t2 As Date
Set s1 = Sheets("Data")
Set s2 = Sheets("Listele")
Set d = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A2:J" & s1.Cells(Rows.Count, 1).End(3).Row).Value
t1 = s2.[B2]
t2 = s2.[C2]

For i = 1 To UBound(a)
    If a(i, 7) >= t1 And a(i, 7) <= t2 Then
    krt = a(i, 1)
        If d.exists(krt) Then
            If a(i, 7) > a(d(krt), 7) Then
                d(krt) = i
            End If
        Else
            d(krt) = i
        End If
    End If
Next i

If d.Count > 0 Then
    Application.ScreenUpdating = False
    s2.Range("A5:J" & Rows.Count).ClearContents
    ReDim b(1 To d.Count, 1 To UBound(a, 2))
    For Each v In d.keys
        say = say + 1
        b(say, 1) = v
        For y = 2 To UBound(a, 2)
            b(say, y) = a(d(v), y)
        Next y
    Next v
    s2.[G5].Resize(say, 3).NumberFormat = "dd.mm.yyyy"
    s2.[E5].Resize(say).NumberFormat = "@"
    s2.[A5].Resize(say, UBound(a, 2)) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam.", vbInformation
Else
    MsgBox "Sonuç bulunamadı.", vbCritical
End If
End Sub

 

[Haluk]

Alternatif,

Dizi yöntemi ile yapılan çalışma.

"Anında görüntü...." diye buna derim işte .... tebrikler.

.

 

[denese]

Alternatif,

Dizi yöntemi ile yapılan çalışma.

Sub test()
Dim t1 As Date, t2 As Date
Set s1 = Sheets("Data")
Set s2 = Sheets("Listele")
Set d = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A2:J" & s1.Cells(Rows.Count, 1).End(3).Row).Value
t1 = s2.[B2]
t2 = s2.[C2]

For i = 1 To UBound(a)
    If a(i, 7) >= t1 And a(i, 7) <= t2 Then
    krt = a(i, 1)
        If d.exists(krt) Then
            If a(i, 7) > a(d(krt), 7) Then
                d(krt) = i
            End If
        Else
            d(krt) = i
        End If
    End If
Next i

If d.Count > 0 Then
    Application.ScreenUpdating = False
    s2.Range("A5:J" & Rows.Count).ClearContents
    ReDim b(1 To d.Count, 1 To UBound(a, 2))
    For Each v In d.keys
        say = say + 1
        b(say, 1) = v
        For y = 2 To UBound(a, 2)
            b(say, y) = a(d(v), y)
        Next y
    Next v
    s2.[G5].Resize(say, 3).NumberFormat = "dd.mm.yyyy"
    s2.[E5].Resize(say).NumberFormat = "@"
    s2.[A5].Resize(say, UBound(a, 2)) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam.", vbInformation
Else
    MsgBox "Sonuç bulunamadı.", vbCritical
End If
End Sub

Mükemmel çalışıyor. Elinize sağlık.

 

[YUSUF44]

Sayın Ziynettin, bu kodu açıklayabilir misiniz? Nasıl bu kadar hızlı çalışıyor?

 

[Ziynettin]

"Anında görüntü...." diye buna derim işte .... tebrikler.

.

Teşekkürler Haluk bey.

 

[Ziynettin]

Mükemmel çalışıyor. Elinize sağlık.

Güle güle kullanın.
İyi çalışmalar.

 

[Ziynettin]

Sayın Ziynettin, bu kodu açıklayabilir misiniz? Nasıl bu kadar hızlı çalışıyor?

Yusuf Bey, müsait zamanda detaylı açıklamayı yapmaya çalışırım.

 

[Aycup]

bilgileriniz çok değerli. teşekkür ederiz.

 

[denese]

Merhaba değerli hocalarım,

2 nolu mesajdaki Sayın @Ömer BARAN' ın "Kriterli_listeleme" makrosunu, benzer bir çalışmaya uyarlamaya çalıştım. Fakat işin içinden çıkamadım. Detayları ekli dosya üzerinde belittim. Tekrar yardımlarınızı rica ediyorum.

Yukarıda, benzer bir çalışmadaki sayın @Ziynettin' e ait kod gerçekten çok hızlı. Ekteki çalışmayı da aynı yöntemle yapabilir miyiz?

İyi günler dilerim.

 

[Ömer BARAN]

Merhaba.
İlgili kod aşağıdaki gibi güncellenirse istenilen sonucu verecektir.

Sub Mutabakat_izinleri_listele()
Set d = Sheets("Data"): Set m = Sheets("Mutabakat")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If d.AutoFilterMode = True Then d.AutoFilterMode = False
dson = d.Cells(Rows.Count, 1).End(3).Row
    If m.[F5] <> "" And m.[F6] <> "" And m.[F6] < m.[F5] Then
        MsgBox "Başlangıç tarihi, bitiş tarihinden küçük olmalıdır."
        Exit Sub
    End If
 
    If m.[I3] = "" Then
        d.Range("A1:J1").AutoFilter Field:=1
            Else
                d.Range("A1:J1").AutoFilter Field:=1, Criteria1:=m.[I3]
                    End If
                        If m.[F5] = "" Then
                            d.Range("A1:J1").AutoFilter Field:=7
                                Else
                            d.Range("A1:J1").AutoFilter Field:=7, Criteria1:=">=" & CLng(m.[F5])
                        End If
                    If m.[F6] = "" Then
                d.Range("A1:J1").AutoFilter Field:=8
            Else
        d.Range("A1:J1").AutoFilter Field:=8, Criteria1:="<=" & CLng(m.[F6])
    End If
 
    If d.Cells(Rows.Count, 1).End(3).Row > 1 Then
        If m.Cells(Rows.Count, 1).End(3).Row > 20 Then m.Range("A21:K" & m.Cells(Rows.Count, 1).End(3).Row).ClearContents
        d.Range("D2:E" & dson).Copy : m.[A21].PasteSpecial Paste:=xlPasteValues
        d.Range("G2:J" & dson).Copy : m.[C21].PasteSpecial Paste:=xlPasteValues
        mesaj = m.Cells(Rows.Count, 1).End(3).Row - 20 & " adet kayıt listelendi."
    Else
        mesaj = "Aranan kriterlere uygun veri yok."
    End If
If d.AutoFilterMode = True Then d.AutoFilterMode = False
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox mesaj
End Sub

 

[denese]

Sayın @Ömer BARAN, ilginize ve desteğinize tekrar teşekkür ediyorum. Data sayfasındaki veriler formül içerdiğinde, Mutabakat sayfasında, izin gün sayısı sütununa aktarılan hücreler aşağıdaki şekilde hata veriyor.


Verileri değerlerini yapıştırarak listeyebilir miyiz?

 

[Ömer BARAN]

Bir önceki cevabımda kırmızı renklendirdiğim kısımları düzeltin/ekleyin.

Aslında gördüğüm kadarıyla Data sayfası SİCİL numarası ve İZİN BAŞLAMA TARİHİne göre sıralı gibi.
Eğer belge kullanım düzeniniz hep böyle ise; kod'da alternatif öneri de olabilir.

 

[denese]

Sayın @Ömer BARAN, Mutabakat sayfasına listelenen verilerin tümü için DEĞERLERİ YAPIŞTIR uygulayabilir miyiz? İzin Gün Sayısı sütunu haricindeki diğer verileri hücre biçimleriyle ve formülleriyle kopyalıyor.

 

[Ömer BARAN]

İşte burada yine aynı duruma geliyoruz; "örnek belgenin gerçek belgenin kopyası şeklinde hazırlanmamış olması".

Kod'da tekrar kırmızı renklendirerek değişiklik yaptım ( ilgili satırlarda aralara eklenen : karakterlerine ve ClearContents ibaresine dikkat)
Sayfayı yenileyerek kontrol ediniz.

Bu arada Mutabakat sayfasındaki sütunların biçimlendirilmesi işlemini bir defalığına mahsus elle yapın (tarih/sayı vs).
.

 

[denese]

Aslında bu hususa dikkat ediyorum. Data sayfasındaki "İş Başı Tarihi" ve "İzin Gün Sayısı" sütunundaki formülleri sildiğimde, Listeleme' de bu karışıklığa neden olacağını öngöremedim. Kusura bakmayın.

Desteğiniz için sonsuz teşekkürler.