VBA ile yapılan ETOPLA İşleminin Hızını Arttırma Yolu

ccuneyt13 · 25 Ocak 2023

Merhaba,
Bir listem var, ve listemde TC ve Borç Tutarı bilgileri var,
Aşağıdaki kod ile TC'ye göre borç tutarlarını etopla ile toplatıyorum,
Sorunum şu;
Listem 100 bin satırdan oluşuyor ve bu kod yaklaşık 45 dakika sürüyor.
Bu noktada yaptığım işlemi kısa sürede (bir kaç dakika da) yapabilecek bir yöntem olabilir mi ?
Yada aşağıda ki kodda revize vs. bir şekilde süreyi bir kaç dakikaya indirme şansım olabilir mi?
Teşekkür ederim.



Sub etopla()

Application.ScreenUpdating = False

Dim s1 As Worksheet:

Dim i 

Set s1 = ThisWorkbook.Sheets("DATA") 

Son = Sheets("DATA").Cells(Rows.Count, 1).End(xlUp).Row 

Set wf = WorksheetFunction

For i = 2 To Son

s1.Range("BV" & i) = wf.SumIf(s1.Range("h2:h" & Son), s1.Range("h" & i), s1.Range("m2:m" & Son))

Next

MsgBox "İşlem tamamlandı", vbInformation, "BİTTİ"

End Sub

Muzaffer Ali · 25 Ocak 2023

Merhaba.

Kod:

Sub etopla()
    Dim SonSatir As Long
    With Sheets("DATA")
        SonSatir = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("BV2:BV" & SonSatir).Formula = "=sumif(h2:h" & SonSatir & ", h2, m2:m" & SonSatir & ")"
        .Range("BV2:BV" & SonSatir).Value = Range("BV2:BV" & SonSatir).Value
    End With
    MsgBox "İşlem tamamlandı", vbInformation, "BİTTİ"
End Sub

ccuneyt13 · 26 Ocak 2023

Muzaffer Ali' Alıntı:

Merhaba.

Kod:

Sub etopla()
    Dim SonSatir As Long
    With Sheets("DATA")
        SonSatir = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("BV2:BV" & SonSatir).Formula = "=sumif(h2:h" & SonSatir & ", h2, m2:m" & SonSatir & ")"
        .Range("BV2:BV" & SonSatir).Value = Range("BV2:BV" & SonSatir).Value
    End With
    MsgBox "İşlem tamamlandı", vbInformation, "BİTTİ"
End Sub

Muzaffer Bey Merhaba,
İlginize teşekkür ederim, hızlanmasına hızlandı fakat şöyle bir durum oldu,
Örnek:
123456789012 nolu TC ye ait 3 farklı borç var. Satır sırasıyla 50-100-200 olsun,
İlk bulduğuna bu TC nin karşısına olması gerektiği gibi doğru olarak toplama 350 yazdı,
Ama bu aynı TC nin 2. kez tekrarlanan ilgili satırdaki toplamına ilk bulduğunun borcu kadar eksik yani 300 yazdı,
3. aynı TC olana da sadece 200 yazdı.
Etopla aynı olan 3 tanesine de 350 yazmalıydı.

Erdem Akdemir · 26 Ocak 2023

Örnek dosya ekleyebilirmisiniz.

Korhan Ayhan · 26 Ocak 2023

Alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Hız konusunda oldukça avantaj sağlayacaktır.

C++:

Option Explicit

Sub FAST_SUMIF()
    Dim S1 As Worksheet, TCNO As Object, X As Long
    Dim My_Data As Variant, Sum_List As Variant
    Dim Count_Data As Long, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("DATA")
    Set TCNO = VBA.CreateObject("Scripting.Dictionary")
    
    S1.Range("BV2:BV" & S1.Rows.Count).ClearContents
    
    My_Data = S1.Range("A1").CurrentRegion.Value
    
    ReDim Sum_List(1 To UBound(My_Data, 1), 1 To 1)
    
    For X = 2 To UBound(My_Data, 1)
        TCNO.Item(My_Data(X, 8)) = TCNO.Item(My_Data(X, 8)) + My_Data(X, 13)
    Next
        
    For X = 2 To UBound(My_Data, 1)
        Sum_List(X - 1, 1) = TCNO.Item(My_Data(X, 8))
    Next
    
    S1.Range("BV2").Resize(UBound(My_Data, 1), 1) = Sum_List
    S1.Columns("BV").AutoFit
    
    Set S1 = Nothing
    Set TCNO = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

Korhan Ayhan · 26 Ocak 2023

Bu da ADO ile alternatif olsun..

Sonuç alabilmeniz için sorgu satırında B8 ve B13 olarak yazdığım sütun başlıklarını orjinal dosyanızdaki başlıklara göre revize etmeniz gerekir.

C++:

Option Explicit

Sub ADO_SUMIF()
    Dim My_Connection As Object, My_Recordset As Object
    Dim My_Query As String, Process_Time As Double
   
    Process_Time = Timer
   
    Application.ScreenUpdating = False
   
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
   
    With Sheets("DATA")
        .Range("BV2:BV" & .Rows.Count).ClearContents
   
        My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
        ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
       
        My_Query = "Select Tablo_2.Toplam From [DATA$] As Tablo_1 " & _
                   "Left Join (Select B8, Sum(B13) As Toplam From [DATA$] Group By B8) As Tablo_2 " & _
                   "On Tablo_1.B8 = Tablo_2.B8"
       
        Set My_Recordset = My_Connection.Execute(My_Query)
          
        .Range("BV2").CopyFromRecordset My_Recordset
    End With
   
    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
   
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

halit3 · 26 Ocak 2023

Dosyada formül çoksa aşağıdaki kod da işe yarar

Rich (BB code):

Sub etopla()


With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


'kodlarınız.....?


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

MsgBox "işlem tamam"
End Sub

ccuneyt13 · 26 Ocak 2023

Korhan Ayhan' Alıntı:

Alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Hız konusunda oldukça avantaj sağlayacaktır.

C++:

Option Explicit

Sub FAST_SUMIF()
    Dim S1 As Worksheet, TCNO As Object, X As Long
    Dim My_Data As Variant, Sum_List As Variant
    Dim Count_Data As Long, Process_Time As Double
   
    Process_Time = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("DATA")
    Set TCNO = VBA.CreateObject("Scripting.Dictionary")
   
    S1.Range("BV2:BV" & S1.Rows.Count).ClearContents
   
    My_Data = S1.Range("A1").CurrentRegion.Value
   
    ReDim Sum_List(1 To UBound(My_Data, 1), 1 To 1)
   
    For X = 2 To UBound(My_Data, 1)
        TCNO.Item(My_Data(X, 8)) = TCNO.Item(My_Data(X, 8)) + My_Data(X, 13)
    Next
       
    For X = 2 To UBound(My_Data, 1)
        Sum_List(X - 1, 1) = TCNO.Item(My_Data(X, 8))
    Next
   
    S1.Range("BV2").Resize(UBound(My_Data, 1), 1) = Sum_List
    S1.Columns("BV").AutoFit
   
    Set S1 = Nothing
    Set TCNO = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

Korhan Bey, bu kodları kendi tabloma göre revize ettim, sonuç muhteşem. 45 dakika süren işlem 1.96 saniye bitti.
Toplam sonuçları da tam ve doğru.
Çok şaşırdım, çok sevindim.

Ne kadar teşekkür etsem azdır.
Alternatif olarak ilettiğinize ADO çözümünü de dosyama göre revize edip sonucu paylaşacağım.
Elinize kolunuza sağlık. Çok teşekkür ederim.

Erdem Akdemir · 26 Ocak 2023

Korhan bey merhaba,

Dizi yöntemi ile yaptığınızda sanırım tüm alanları bir kerede hesaplıyor ve hücresinin karşısına yazıyor.
Kendi istediğimiz alanların toplamını ayrı bir sayfada hesaplatmak istersek kodu nasıl revize etmeliyiz.

ccuneyt13 · 26 Ocak 2023

halit3' Alıntı:

Dosyada formül çoksa aşağıdaki kod da işe yarar

Rich (BB code):

Sub etopla()


With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


'kodlarınız.....?


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

MsgBox "işlem tamam"
End Sub

Halit Bey Merhaba,
Öncelikle size de alakanız için teşekkür ederim.
İlk mesajımda ki kodu belirttiğiniz şekilde "'kodlarınız....?" kısmına alarak denedim şuan 20 dakika oldu. Halen çalışıyor.
Ben mi hatalı güncelledim, yoksa beklenen süre bir miktar mı azalma gösterecek tam anlayamadım.
Yine çok teşekkür ederim.
Diğer kod fazlasıyla süre sorunu mu çözmüş oldu.

ccuneyt13 · 26 Ocak 2023

Korhan Ayhan' Alıntı:

Bu da ADO ile alternatif olsun..

Sonuç alabilmeniz için sorgu satırında B8 ve B13 olarak yazdığım sütun başlıklarını orjinal dosyanızdaki başlıklara göre revize etmeniz gerekir.

C++:

Option Explicit

Sub ADO_SUMIF()
    Dim My_Connection As Object, My_Recordset As Object
    Dim My_Query As String, Process_Time As Double
  
    Process_Time = Timer
  
    Application.ScreenUpdating = False
  
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
  
    With Sheets("DATA")
        .Range("BV2:BV" & .Rows.Count).ClearContents
  
        My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
        ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
      
        My_Query = "Select Tablo_2.Toplam From [DATA$] As Tablo_1 " & _
                   "Left Join (Select B8, Sum(B13) As Toplam From [DATA$] Group By B8) As Tablo_2 " & _
                   "On Tablo_1.B8 = Tablo_2.B8"
      
        Set My_Recordset = My_Connection.Execute(My_Query)
         
        .Range("BV2").CopyFromRecordset My_Recordset
    End With
  
    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
  
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

Korhan Bey tekrar merhaba,
Set My_Recordset = My_Connection.Execute(My_Query) satırında aşağıdaki gibi hata verdi.

Korhan Ayhan · 26 Ocak 2023

Başlıkları kod içinde düzeltmeniz gerekiyor.

Başlıkları gösteren basit bir örnek dosya paylaşırsanız kodu düzenleyebilirim.

Korhan Ayhan · 26 Ocak 2023

Erdem Akdemir' Alıntı:
Korhan bey merhaba,

Dizi yöntemi ile yaptığınızda sanırım tüm alanları bir kerede hesaplıyor ve hücresinin karşısına yazıyor.
Kendi istediğimiz alanların toplamını ayrı bir sayfada hesaplatmak istersek kodu nasıl revize etmeliyiz.

Erdem Bey,

Özelden paylaştığınız dosyaya kodu uyarladım. Dosya Ektedir.

Erdem Akdemir · 26 Ocak 2023

Korhan bey elinize sağlık.

Erdem Akdemir · 30 Ocak 2023

@korhan bey artan sıralamada bir toplama yaptırmak istersek kod nasıl olmalı.

A	40	40
A	10	50
C	30	30
E	50	50
G	20	20
Z	50	50
B	20	20
A	10	60

Korhan Ayhan · 30 Ocak 2023

@Erdem Akdemir,

Paylaştığınız örnek dosyanıza 3. bir sayfa ekleyip aşağıdaki kodu deneyiniz.

C++:

Option Explicit

Sub FAST_CUMULATIVE_SUMIF()
    Dim S1 As Worksheet, TCNO As Object, X As Long
    Dim My_Data As Variant, Sum_List As Variant
    Dim Count_Data As Long, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa3")
    Set TCNO = VBA.CreateObject("Scripting.Dictionary")
    
    S1.Range("C2:C" & S1.Rows.Count).ClearContents
    
    My_Data = S1.Range("A1").CurrentRegion.Value
    
    ReDim Sum_List(1 To UBound(My_Data, 1), 1 To 1)
    
    For X = 2 To UBound(My_Data, 1)
        TCNO.Item(My_Data(X, 1)) = TCNO.Item(My_Data(X, 1)) + My_Data(X, 2)
        Sum_List(X - 1, 1) = TCNO.Item(My_Data(X, 1))
    Next
        
    S1.Range("C2").Resize(UBound(My_Data, 1), 1) = Sum_List
    S1.Columns("C").AutoFit
    
    Set S1 = Nothing
    Set TCNO = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

Mdemir63 · 30 Ocak 2023

Korhan Ayhan' Alıntı:
Erdem Bey,

Özelden paylaştığınız dosyaya kodu uyarladım. Dosya Ektedir.

@Korhan Ayhan Hocam bu dosya da tek kriter (E topla) var, birden fazla kriter (ÇokEtopla) olduğunda kodlarınızda ne gibi değişiklik yapmamız gerekir

Saygılar

Korhan Ayhan · 30 Ocak 2023

@Mdemir63,

Sizde konuyla ilgili örnek dosya paylaşırsanız yardımcı olabilirim.

Mdemir63 · 30 Ocak 2023

Korhan Ayhan' Alıntı:
@Mdemir63,

Sizde konuyla ilgili örnek dosya paylaşırsanız yardımcı olabilirim.

Buyrun Hocam dosya ekte

Korhan Ayhan · 30 Ocak 2023

Görmek istediğiniz sonuç nedir?

VBA ile yapılan ETOPLA İşleminin Hızını Arttırma Yolu

ccuneyt13

Muzaffer Ali

Destek Ekibi

ccuneyt13

Erdem Akdemir

Destek Ekibi

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

halit3

Uzman

ccuneyt13

Erdem Akdemir

Destek Ekibi

ccuneyt13

ccuneyt13

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Ekli dosyalar

Erdem Akdemir

Destek Ekibi

Erdem Akdemir

Destek Ekibi

Korhan Ayhan

Administrator

Mdemir63

Korhan Ayhan

Administrator

Mdemir63

Ekli dosyalar

Korhan Ayhan

Administrator