Soru e topladan başka formül

[NADİR YILDIZ]

arkadaşlar bu başlıklar adı altında yaklaşık 15.000 satırlık bir liste var.Etopla formülü ile yaptığımda sonuç elde ediyorum ancak toplamları alırken excel dosyası çok kasılıyor.başka bir formül yada makro ile çözüm yolu varmı acaba ?

 

[Ziynettin]

Sub toplam_al()
Set dc1 = CreateObject("scripting.dictionary")
Set dc2 = CreateObject("scripting.dictionary")
Set dc3 = CreateObject("scripting.dictionary")
a = Range("L3:AJ" & Cells(Rows.Count, "L").End(3).Row).Value
For i = 1 To UBound(a)
    mth = a(i, 10): dc1(mth) = dc1(mth) + a(i, 5)
    kms = a(i, 1): dc2(kms) = dc2(kms) + a(i, 17)
    net = a(i, 10): dc3(net) = dc3(net) + a(i, 25)
Next i
b = Range("AP3:AP" & Cells(Rows.Count, "AP").End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 3)
For i = 1 To UBound(b)
    krt = b(i, 1)
    c(i, 1) = CDbl(dc1(krt))
    c(i, 2) = CDbl(dc2(krt) * -1)
    c(i, 3) = CDbl(dc3(krt))
Next i
[AQ3].Resize(UBound(b), 3) = c
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[Merhum İdris SERDAR]

.

Pivot Table - Özet Tabloyu kullanın daha uygun olur.

.

 

[NADİR YILDIZ]

sayın ziynettin kod için teşekkür ederim.
dosyam ektedir.
kodu uyguladığımda örnekteki gibi listeliyor.tamamı gelmiyor
renklendirdiğim alanları listelemek istiyorum.
dosyayı yine dosyada kasılma devam ediyor.
dosya daha uzun yaklaşık 15.000 satır var ancak satırları sildim
iyi çalışmalar

 

[NADİR YILDIZ]

.

Pivot Table - Özet Tabloyu kullanın daha uygun olur.

.

sayın idris bey çözüm öneriniz için teşekkürler
dosyaya nasıl uygulayabilirim

iyi çalışmalar

 

[Ziynettin]

AP sütunundaki tarihler formulle ve diğer sutunlarda formulle veriler listeniyor. Formul ile veri almamaya çalışın.

Sub Düğme56_Tıklat()
Dim mth As String, kms As String, net As String, krt As String
Application.Calculation = xlCalculationManual
Set dc1 = CreateObject("scripting.dictionary")
Set dc2 = CreateObject("scripting.dictionary")
Set dc3 = CreateObject("scripting.dictionary")
a = Range("L3:AJ" & Cells(Rows.Count, "L").End(3).Row).Value
For i = 1 To UBound(a)
    mth = a(i, 10): dc1(mth) = dc1(mth) + a(i, 5)
    kms = a(i, 1): dc2(kms) = dc2(kms) + a(i, 17)
    net = a(i, 10): dc3(net) = dc3(net) + a(i, 25)
Next i
On Error Resume Next
b = Range("AP3:AP" & Cells(Rows.Count, "AP").End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 4)
ReDim c1(1 To UBound(b), 1 To 3)
deg = CDbl([AT2])
For i = 1 To UBound(b)
    krt = 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
[AQ3].Resize(UBound(b), 4) = c
MsgBox "İşlem bitti.", vbInformation
'Application.Calculation = xlCalculationAutomatic
End Sub

 

[NADİR YILDIZ]

Sayın Ziynettin teşekkürler
dediğiniz gibi formüllerden dolayı kasma yapıyor.
AP sütunundaki formülleri kaldırınca kasılma problemi kalmadı.
ancak gönderdiğim örnekte lacivert ile işaretli olan bölümde V sütunundaki hesaba geçiş tarihine göre listelemek istiyorum
sizin yazdığınız kod ise L sütununda işlem tarihine göre listeliyor.

a = Range("L3:AJ" & Cells(Rows.Count, "L").End(3).Row).Value
L'yi V olarak değiştirdiğimde ise

kms = a(i, 1): dc2(kms) = dc2(kms) + a(i, 17)
debug mesajı veriyor.

nasıl düzenleyebiliriz.

iyi çalışmalar

 

[Ziynettin]

Tablo boyutunu değiştiğinde sutun index leride değişir. Kod tabloya göre yeniden düzenlenmeli. Aksi durumda hata kaçınılmaz.

Son eklediğiniz dosyada matrah, komisyon, net formul ile düzenleyiyin. Tarihlere göre toplamlar hangi sutundan alınıyor formulden anlamış oluruz.
Yeniden dosya ekeleyin yardımcı olmaya çalışalım.

 

[NADİR YILDIZ]

ziynettin bey ben V sütunundaki hesaba geçiş tarihine göre toplamları aldırmak istiyorum.formülleri yazdım ayrıca renklendirdim.hangi sütundaki toplamları aldırmak istediğimi.sizin yazdığınız kod da L sütunundaki işlem tarihine göre yukarıda ki toplamları aldırıyor.benim istediğim.V sütunundaki hesaba geçiş tarihine göre yukarıda ki toplamları aldırmak istiyorum.

iyi çalışmalar

 

[Merhum İdris SERDAR]

.

Pivot - Özet Tablo ile yapılmış dosyanız ekte.

.

 

[NADİR YILDIZ]

İdris bey teşekkür ederim
iyi çalışmalar

 

[NADİR YILDIZ]

ziynettin bey makro ile çözümü ulaşabildiniz mi ?

 

[Ziynettin]

Sub test()
Dim mth As String, kms As String, net As String, krt As String
Application.Calculation = xlCalculationManual
Set dc1 = CreateObject("scripting.dictionary")
Set dc2 = CreateObject("scripting.dictionary")
Set dc3 = CreateObject("scripting.dictionary")
a = Range("P3:AJ" & Cells(Rows.Count, "V").End(3).Row).Value
For i = 1 To UBound(a)
trh = CStr(a(i, 7))
dc1(trh) = dc1(trh) + a(i, 1)
dc2(trh) = dc2(trh) + a(i, 13)
dc3(trh) = dc3(trh) + a(i, 21)
Next i
'On Error Resume Next
b = Range("AP3:AP" & Cells(Rows.Count, "AP").End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 4)
deg = CDbl([AT2])
For i = 1 To UBound(b)
    krt = 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
[AQ3].Resize(UBound(b), 4) = c
MsgBox "İşlem bitti.", vbInformation
'Application.Calculation = xlCalculationAutomatic
End Sub

 

[NADİR YILDIZ]

Sayın ziynettin teşekkürler
sizi çok uğraştırdım
Hakkınızı helal edin

iyi çalışmalar