iki tarih arası ilave

[igultekin2000]

iyi akşamlar;
Forumda ki iki tarih arası veri getirme makro' ya bir de isim seçeneği eklemek istiyordum. Gereken bilgim yoktur.
Teşekkürler.

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) & "|" & Veri(X, 5) & "|" & Veri(X, 6)
            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

 

[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") And Veri(X, 2) = S2.Range("D2") Then
            Aranan = Veri(X, 1) & "|" & Veri(X, 5) & "|" & Veri(X, 6)
            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

 

[igultekin2000]

Deneyiniz.

teşekkür ederim, sorunsuz çalışıyor, iyi çalışmalar.