İKİ TARİH ARASI VERİ GETİR

[Korhan Ayhan]

Benim paylaştığım dosyada gruplandırma aşağıdaki kriterlere göre yapılıyor.

KURUM NO
ÜNİTESİ
TALEP EDİLEN ÇAYIN CİNSİ

En son seçenek devrede olduğu için kişiye ait birden fazla satır çıkıyor.

Sizin görmek istediğiniz sonuç nasıldı?

 

[polis-53]

Korhan bey seçtiğim tarihler arası kişi birden fazla kaydı var ise bu kayıtların toplamını istiyorum

 

[Korhan Ayhan]

Sizin paylaştığınız dosyadaki formüllerin sonuçları doğru muydu?

Ya da şöyle yapalım. Görmek istediğiniz sonucu örneklendirir misiniz?

 

[polis-53]

Resimden de anlaşılacağı gibi seçilen tarihlerde kişi birden çok talebi var ben bu taleplerin toplamlarını istiyorum.

 

[Korhan Ayhan]

Orasını anladım. Nokta atışı için şu veriyi şu şekilde görmek istiyorum diye örnek dosyada gösterirseniz ben kodu düzenlerim.

 

[Korhan Ayhan]

Siz hücrelere dağıtılan değerlerin nerede paylaşıldığını sormuyor musunuz?

Örnek dosyada çalışan makro sonucunda F4 = 1 ve G4 = 0,20 değerlerini alıyor. Yani D4 hücresindeki 1,20 değeri bu iki hücreye dağılıyor.

Bu işlemi bahsettiğim satır hesaplıyor..

 

[polis-53]

[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]
[TR][TD]
Başlama Tarihi 01.01.2020 Bitiş Tarihi 31.12.2020 olan kişinin verileri aşağıdaki gibi gelecek.
[/TD][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]

 

[Korhan Ayhan]

Peki son bir soru. Gruplandırma KURUM NO üzerinden mi yapılsın? Yoksa ADI SOYADI üzerinden mi yapılsın?

Çünkü KURUM NO üzerinden yapınca aşağıdaki benzer isimler mükerrer görünüyor. Eğer AD SOYAD üzerinden gruplandıralım derseniz ikinci kurum nolar için bir işlem yapılacak mı?

 

[polis-53]

Merhabalar Kurum No üzerinden yapılsın Bazı kişilerin kurum noları yanlış girişmiş.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Tarih_Araligina_Gore_Ozet_Rapor_Dictionary()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Son As Long, Say As Long
    Dim Veri As Variant, X As Long, Aranan As String, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("LİSTE")
    Set S2 = Sheets("RAPOR")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    S2.Range("A6:E" & S2.Rows.Count).Clear
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = S1.Range("A2:N" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 5)
   
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 8) >= S2.Range("B2") And Veri(X, 8) <= S2.Range("B3") Then
            Aranan = Veri(X, 1)
            If Not Dizi.Exists(Aranan) Then
                Say = Say + 1
                Dizi.Add Aranan, Say
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Veri(X, 2) & " " & Veri(X, 3)
                Liste(Say, 3) = Veri(X, 4)
                Liste(Say, 4) = Veri(X, 9)
                Liste(Say, 5) = Veri(X, 11)
            Else
                Liste(Dizi.Item(Aranan), 4) = Liste(Dizi.Item(Aranan), 4) + Veri(X, 9)
                Liste(Dizi.Item(Aranan), 5) = Liste(Dizi.Item(Aranan), 5) + Veri(X, 11)
            End If
        End If
    Next
   
    If Say > 0 Then
        S2.Range("A6").Resize(Say, 5) = Liste
        S2.Range("A6").Resize(Say, 5).Sort S2.Range("A6"), xlAscending
        S2.Range("A6").Resize(Say, 5).Borders.LineStyle = 1
        S2.Range("A6").Resize(Say).HorizontalAlignment = xlCenter
        S2.Range("D6").Resize(Say, 2).Style = "Comma"
        S2.Columns.AutoFit
       
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
       
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
   
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
       
        MsgBox "Girilen tarihlerde veri bulunamadı!" & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbExclamation
    End If
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[polis-53]

çok teşekkür ederim kal sağlıcakla