Makro ile tarih aralığını toplama

[kadir78]

İyi günler. A sütununda 500 satır içinde tarihler var ve B sütununda tutarlar var D1 ve E1 hücrelerine girilen tarihler arasındaki B sütunlarının toplamını F1 hücresinde gösterilmesi için makro kodlarına ihtiyacım var. Yardımcı olursanız sevinirim.

 

[PLİNT]

Merhaba
Aşağıdaki kod "E1" ve "D1" hücrelerine tarih yazıldığında çalışır
(Yazılan tarihlerin dahil edilmemesi gerek ise; için kod içinde bulunan ">=", "<=" ibarelerini düzeltirsiniz.)
"A" sütunu hücreleri tarih formatlı olmalıdır

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D1:E1")) Is Nothing Then Exit Sub
If IsDate([D1].Value) = False Or IsDate([E1].Value) = False Then Exit Sub
If CDate([D1]) > CDate([E1]) Then MsgBox "İlk tarih büyük olamaz": Exit Sub
Dim x As Long
x = Cells(Rows.Count, "A").End(3).Row
[F1] = 0
[F1] = Application.WorksheetFunction.SumIfs(Range("B2:B" & x), Range("A2:A" & x), ">=" & CDbl(CDate([D1])), Range("A2:A" & x), "<=" & CDbl(CDate([E1])))
End Sub

 

[kadir78]

Elinize emeğinize sağlık. Kodlar için teşekkür ederim.

 

[kadir78]

Sayın PLİNT yazdığınız kodlar ilgili bir sorum daha olacaktı. Kodlar sorunsuz çalışıyor fakat A sütunundaki tarihlere filtre işlemi yaptığım zaman (örnek olarak A sütununa filtre uygulayıp 01.01.2021 ve 04.01.2021 tarihlerini seçtiğimde ve tarih aralığına 01.012021 ve 04.01.2021 yazdığımda burada 02 ve 03 tarihlerini toplamayacak sadece 01 ve 04 tarihlerini toplayacak) filtre uygulanmış satırları değilde bütün satırları toplama işlemi yapıyor. Sadece filtre uygulanmış satırları toplama işlemi yapmak için nasıl bir kod eklemek gerekir. Yardımcı olursanız sevinirim.

 

[tacettinsal]

Sayın PLİNT yazdığınız kodlar ilgili bir sorum daha olacaktı. Kodlar sorunsuz çalışıyor fakat A sütunundaki tarihlere filtre işlemi yaptığım zaman (örnek olarak A sütununa filtre uygulayıp 01.01.2021 ve 04.01.2021 tarihlerini seçtiğimde ve tarih aralığına 01.012021 ve 04.01.2021 yazdığımda burada 02 ve 03 tarihlerini toplamayacak sadece 01 ve 04 tarihlerini toplayacak) filtre uygulanmış satırları değilde bütün satırları toplama işlemi yapıyor. Sadece filtre uygulanmış satırları toplama işlemi yapmak için nasıl bir kod eklemek gerekir. Yardımcı olursanız sevinirim.

Merhaba,
sevgili @PLİNT arkadaşımızın kodlarına bazı kodlar ekledim. Ancak filtreleme yaptıktan sonra tarih kısımlarını tekrardan girmeniz gerekiyor. Önce tarihleri girerseniz kod çalışıyor, malesef sonrasında filtreleme yaparsanız kodu tetikleyemedim. Nasıl yapılır biraz inceledim ama bulamadım. Bilen birisi varsa yardımcı olabilir. Deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D1:E1")) Is Nothing Then Exit Sub
If IsDate([D1].Value) = False Or IsDate([E1].Value) = False Then Exit Sub
If CDate([D1]) > CDate([E1]) Then MsgBox "İlk tarih büyük olamaz": Exit Sub
son = Excel.WorksheetFunction.CountA(Range("A:A"))
Application.ScreenUpdating = False
For i = 2 To son
    If Cells(i, 1) >= Cells(1, 4) And Cells(i, 1) <= Cells(1, 5) Then
    Cells(1, 6) = Excel.WorksheetFunction.Subtotal(109, Range("B2:B" & i))
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[PLİNT]

Merhaba
Aşağıdaki gibi deneyin

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D1:E1")) Is Nothing Then Exit Sub
If IsDate([D1].Value) = False Or IsDate([E1].Value) = False Then Exit Sub
If CDate([D1]) > CDate([E1]) Then MsgBox "İlk tarih büyük olamaz": Exit Sub
Dim x As Long, j As Range
x = Cells(Rows.Count, "A").End(3).Row
Set adr = Range("A2:A" & x).SpecialCells(xlCellTypeVisible).Cells
    [F1] = 0
If ActiveSheet.FilterMode = False Then
[F1] = Application.WorksheetFunction.SumIfs(Range("B2:B" & x), Range("A2:A" & x), ">=" & CDbl(CDate([D1])), Range("A2:A" & x), "<=" & CDbl(CDate([E1])))
Else
For Each j In Range("A2:A" & x).SpecialCells(xlCellTypeVisible).Cells
If j >= CDbl(CDate([D1])) And j <= CDbl(CDate([E1])) Then
[F1] = [F1] + CDbl(Cells(j.Row, "B"))
End If
Next
End If
End Sub

 

[kadir78]

Sayın PLİNT yazdığınız kodlar için çok teşekkür ederim. Elinize emeğinize sağlık. İyi günler.