Soru macro toplamda yavaş çalışma

[incsoft]

Arkadaşlar ekteki dosyada da gördüğünüz gibi A,C,D sütünlarına göre macro ile toplam almaktadır ancak gerçek dosyamda aşırı yavaş çalışmaktadır. A sütünunda değerler aynıysa D sütunundaki değerleri H sütununa birleştirerek , A sütunu değerler farklıysa D sütununa birleştirmeden toplamaktadır. Bunu macrosuz ya da macroda düzenleme yaparak nasıl hızlandırabiliriz?

Teşekkürler..

 

[mesuttasar]

Kodlarınız görebilseydim yada dosyayı upload sitesine yüklemiş olsaydınız yardımcı olabilirdim.

 

[incsoft]

Kodlarınız görebilseydim yada dosyayı upload sitesine yüklemiş olsaydınız yardımcı olabilirdim.

Dosyayı eklemiştim içerisinde kodları vardı. Aşağıdaki adrese de upload ettim

İndir hesapsoru

Dosyayı indir hesapsoru

dosya.co

 

[mesuttasar]

Örnek dosyanızdaki A sütunundaki veriler de aralarda boş satırlar var, onları düzenleyip dpsyanın yedeğini aldıktan sonra aşağıdaki kodları dener misiniz? Birde kodları modüle kopyalayıp diğer yazdığınız kodları worksheet_change vs gibi prosedürleri silip öyle deneyin.

Sub test()
Dim i, j, dgr, son, toplam, syc, sn, sn2 As Long

Sayfa4.Select
son = [a100000].End(3).Row
    
    For i = 2 To son
        toplam = 0
        syc = 0
        dgr = Cells(i, 4)
        sn = Cells(i, 1)
            For j = 1 To son - 1
            sn2 = Cells(i + j, 1)
                If sn = sn2 Then
                toplam = dgr + Cells(i + j, 4)
                syc = syc + 1
                dgr = toplam
                Range("H" & i & ":H" & i + j).Merge
                Range("H" & i) = dgr
                End If
            Next j
            If syc = 0 Then Range("H" & i) = dgr Else Range("H" & i) = toplam
    Next i
End Sub

 

[incsoft]

Örnek dosyanızdaki A sütunundaki veriler de aralarda boş satırlar var, onları düzenleyip dpsyanın yedeğini aldıktan sonra aşağıdaki kodları dener misiniz? Birde kodları modüle kopyalayıp diğer yazdığınız kodları worksheet_change vs gibi prosedürleri silip öyle deneyin.

Sub test()
Dim i, j, dgr, son, toplam, syc, sn, sn2 As Long

Sayfa4.Select
son = [a100000].End(3).Row
   
    For i = 2 To son
        toplam = 0
        syc = 0
        dgr = Cells(i, 4)
        sn = Cells(i, 1)
            For j = 1 To son - 1
            sn2 = Cells(i + j, 1)
                If sn = sn2 Then
                toplam = dgr + Cells(i + j, 4)
                syc = syc + 1
                dgr = toplam
                Range("H" & i & ":H" & i + j).Merge
                Range("H" & i) = dgr
                End If
            Next j
            If syc = 0 Then Range("H" & i) = dgr Else Range("H" & i) = toplam
    Next i
End Sub

Bu şu şekilde işimi görmeyecek Mesut bey, Komut sürekli yeni bir değer girildiğinde,mevcut değer revize edildiğinde otomatik olarak hesaplaması ve H sütününde ETOLA,TOPLA.ÇARPIM vb.. hangi komutla birleştirilen hücrede komutun gözükmesi gerektiğinden olmamıştır. Her seferinde kodu yeniden çalıştırmaya gerek kalmasını istemiyorum. Mesela bir hücrede 10 değeri 200 olarak değiştiyse otomatik olarak H sütünunda ilgili alana otomatik olarak +190 uygulayacak. Sizin dediğinize göre uyarladığım hali ektedir. Eğer yardımcı olabilirseniz çok sevinirim. Teşekkürler.

 

[incsoft]

Kodları aşağıdaki şekilde revize ettim, dener misiniz?

Sub test()
    Dim i As Long, j As Long, dgr As Long, son As Long, syc As Long, sn As Long, sn2 As Long
    Dim frm As String
   
    Sayfa4.Select
    son = [a100000].End(3).Row

    For i = 2 To son
        syc = 0
        dgr = Cells(i, 4)
        sn = Cells(i, 1)
       
        For j = 1 To son - 1
            sn2 = Cells(i + j, 1)
            If sn = sn2 Then
                dgr = dgr + Cells(i + j, 4)
                syc = syc + 1
                frm = "D" & i & "+" & "D" & (i + j)
               
                Range("H" & i & ":H" & i + j).Merge
                Cells(i, 8) = "=" & frm
                Exit For ' Çıkış yaparak aynı grup için birden fazla işlem yapmamayı sağlar
            End If
        Next j
       
        If syc = 0 Then
            Cells(i, 8) = "=" & "D" & i ' Syc = 0 ise formülü yaz
        End If
    Next i
End Sub

Neyse hocam sanırsam olmayacak. Siz birşeyler yapıyorsunuz allah razı olsun ancak isteklerime göre değil. Bu kodları her seferinde modülü çalıştırmam gerekecek birde kod çok yavaş hesaplıyor. Bunu kullanacak kişiler çok seri kullanacağı için bir değer değişince yeniden modül çalıştıramazlar birde o bilgiye sahip değiller. Amacım anlattığım gibi otomatik hücreye veri girilir girilmez hesaplama yapması. Desteğiniz için teşekkür ederim.

 

[mesuttasar]

Merhaba, kusura bakmayın son birkaç gün işlerim nedeniyle çok yoğundum, aşağıdaki kodları deneyebilirsiniz. A sütunundaki boş hücrelerin dolu olması gerekiyor aksi halde boş sıra numarası varsa kodlar sonsuz döngüye girer. Ben dosyanızı 93. sıra numarasına kadar temizledim, yaklaşık 163 satırlık veriyi istediğiniz gibi formülle birleştirme işlemini 10 saniyeden az bir sürede tamamladı. Örnek olması için dosyayı da ekliyorum. Diğer kodları temizleyip aşağıdaki kodları modül içine kopyalayarak çalıştırabilirsiniz.

hesapsoru__version_1_.xlsm dosyasını indir - download

hesapsoru__version_1_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Sub test()
    Dim i As Long, j As Long, dgr As Long, son As Long, syc As Long, sn As Long, sn2 As Long
    Dim formula As String

    Sayfa4.Select
    son = [a100000].End(3).Row

    For i = 2 To son
        syc = 0
        dgr = Cells(i, 4)
        sn = Cells(i, 1)
        formula = ""

        For j = 1 To son - 1
            sn2 = Cells(i + j, 1)
            If sn = sn2 Then
                dgr = dgr + Cells(i + j, 4)
                syc = syc + 1
                formula = formula & "+D" & (i + j)
                Range("H" & i & ":H" & i + j).Merge
            End If
        Next j

        If syc > 0 Then
            formula = "=D" & i & formula ' İlk hücrenin değeri artı diğer hücrelerin adresi
            Cells(i, 8).Formula = formula
        Else
            Cells(i, 8).Formula = "=D" & i ' Syc = 0 ise formülü yaz
        End If
    Next i
End Sub

 

[incsoft]

Merhaba, kusura bakmayın son birkaç gün işlerim nedeniyle çok yoğundum, aşağıdaki kodları deneyebilirsiniz. A sütunundaki boş hücrelerin dolu olması gerekiyor aksi halde boş sıra numarası varsa kodlar sonsuz döngüye girer. Ben dosyanızı 93. sıra numarasına kadar temizledim, yaklaşık 163 satırlık veriyi istediğiniz gibi formülle birleştirme işlemini 10 saniyeden az bir sürede tamamladı. Örnek olması için dosyayı da ekliyorum. Diğer kodları temizleyip aşağıdaki kodları modül içine kopyalayarak çalıştırabilirsiniz.

hesapsoru__version_1_.xlsm dosyasını indir - download

hesapsoru__version_1_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Sub test()
    Dim i As Long, j As Long, dgr As Long, son As Long, syc As Long, sn As Long, sn2 As Long
    Dim formula As String

    Sayfa4.Select
    son = [a100000].End(3).Row

    For i = 2 To son
        syc = 0
        dgr = Cells(i, 4)
        sn = Cells(i, 1)
        formula = ""

        For j = 1 To son - 1
            sn2 = Cells(i + j, 1)
            If sn = sn2 Then
                dgr = dgr + Cells(i + j, 4)
                syc = syc + 1
                formula = formula & "+D" & (i + j)
                Range("H" & i & ":H" & i + j).Merge
            End If
        Next j

        If syc > 0 Then
            formula = "=D" & i & formula ' İlk hücrenin değeri artı diğer hücrelerin adresi
            Cells(i, 8).Formula = formula
        Else
            Cells(i, 8).Formula = "=D" & i ' Syc = 0 ise formülü yaz
        End If
    Next i
End Sub

Gayet güzel elinize sağlık ancak bu her veri girildiğinde elle macro çalıştırılmak zorundamı Mesut bey? Dosya seri kullanılan ve sürekli eklemeler yapılan ve çalıştırılması her seferinde %100 unutulacağından dolayı değer girilir girilmez otomatik olarak çalışması mümkünmüdür?

 

[mesuttasar]

Dosyayı ilk makro ile düzenledikten sonra aşağıdaki kodu çalışma sayfasının kod bölümüne ekleyin, sonraki işlemlerde istediğiniz gibi işlem yapacaktır. Örnek dosya aşağıdaki linktedir.

hesapsoru_rev2.xlsm dosyasını indir - download

hesapsoru_rev2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastRow, sayac, sn3, sn4, ilkSatir, sonSatir, i, son As Long
Dim formul, txt as String

If Not Intersect(Target, Me.Columns(1)) Is Nothing Then
lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
    If Target.Row = lastRow And Target.Column = 1 Then
    son = [a100000].End(3).Row
    formula = ""
    sayac = 0
    sn3 = Cells(son, 1)
    sn4 = Cells(son - 1, 1)
    txt = ""
        If sn3 = sn4 Then
        Range("H" & son - 1 & ":H" & son).Merge
        Cells(son, 8).Select
            If ActiveCell.MergeCells Then
            ilkSatir = ActiveCell.MergeArea.Row
            sonSatir = ilkSatir + ActiveCell.MergeArea.Rows.Count - 1
            formul = "="
                For i = ilkSatir To sonSatir
                formul = formul & "D" & i & "+"
                Next i
            formul = Left(formul, Len(formul) - 1)
            ActiveCell.formula = formul
            End If
        Else
        Cells(son, 8).formula = "=D" & son
        End If
    End If
End If
son = [a100000].End(3).Row
Cells(son, 2).Select
End Sub

 

[incsoft]

Muhteşem Mesut bey elinize sağlık. Aralar satır ekleme yapıldığında kod yenidenmi çalışılmalı? Ona da ufak bir kodda revize olabilirmi? Mesela 12.08.2023 de 1 kayıt girilmesi unutulmuş ve sonradan araya satır eklendi. Otomatik olarak şuan da uygulamıyor ancak kodu çalıştırınca yapıyor.

 

[mesuttasar]

Aslında yerinizde olsam haftada veya ayda bir defa, H sütunundaki verileri tamamen silip birletirilmiş hücreleride eski haline getirip kodu çalıştırırdım.