Soru Tarihe göre aktarım

[NADİR YILDIZ]

Arkadaşlar mavi sütunlardaki bilgileri buraya hesaba geçiş tarihlerine göre aktarmak istiyorum.daha önce forumda bir arkadaş yardımcı olmuş makro ile çözmüştük.ancak soldaki listede sütunların yeri değiştiği için bu makro işe yaramadı.belki değişiklik yaparsanız diye makroyu silmedim.

 

[NADİR YILDIZ]

Sayın dalgalıkur Mavi olan L sütunundaki hesaba geçiş tarilhlerine göre diğer mavi sütunlardaki tutarları AS sütünundaki tarihe göre komisyon net tutar ve işlem tutarı toplamları günlük alacak.daha önce ziynettin bey makrolu çözümde yardımcı olmuştu.ancak sütunlarda değişiklik olduğu için aktarma yapmıyor.yani bir nevi etoplanın makrolu çözümü.liste çok uzun olduğu için makro ile çözümü daha pratik

 

[Ziynettin]

Mevcut kod üzerinden uyarlamaya çalıştım.

Sub test()
Application.Calculation = xlCalculationManual
Set dc1 = CreateObject("scripting.dictionary")
Set dc2 = CreateObject("scripting.dictionary")
Set dc3 = CreateObject("scripting.dictionary")
a = Range("L3:AL" & Cells(Rows.Count, "V").End(3).Row).Value
For i = 1 To UBound(a)
trh = CStr(a(i, 1))
dc1(trh) = dc1(trh) + a(i, 17)
dc2(trh) = dc2(trh) + a(i, 27)
dc3(trh) = dc3(trh) + a(i, 4)
Next i
'On Error Resume Next
b = Range("AS3:AS" & Cells(Rows.Count, "AS").End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 3)
'deg = CDbl([AT2])
For i = 1 To UBound(b)
    krt = CStr(b(i, 1))
    c(i, 1) = CDbl(dc1(krt))
    c(i, 2) = CDbl(dc2(krt) * -1)
    c(i, 3) = CDbl(dc3(krt))
'    If i = 1 Then
'        c(i, 4) = deg + c(i, 3)
'    Else
'        c(i, 4) = dc3(krt) + c(i - 1, 4)
'    End If
Next i
[AT3].Resize(UBound(b), 3) = c
MsgBox "İşlem bitti.", vbInformation
Application.Calculation = xlCalculationAutomatic
End Sub

 

[NADİR YILDIZ]

Sayın ziynettin bey teşekkür ederim.