Makro Hızlandırma Hk.

[mhrcvk]

Arkadaşlar Merhaba,

Çokeğersay için aşağıdaki makroyu çalıştırıyorum fakat çok yavaş işlem yapıyor hızlandırmak için ne yapabilirim yardımcı olabilecek var mı ?

 Sub ÇOKEĞERSAY()

    ActiveCell.FormulaR1C1 = "=COUNTIFS(R2C1:R567827C1,RC6,R2C4:R567827C4,R1C)"
    Range("I2").Select
    Selection.AutoFill Destination:=Range("I2:I249274")
    Range("I2:I249274").Select
End Sub

http://dosya.co/vuhz3plmswo4/Test.xlsm.html

 

[askm]

 Sub ÇOKEĞERSAY()
With Application
   .ScreenUpdating = False
   .Calculation = xlCalculationManual
End With

    ActiveCell.FormulaR1C1 = "=COUNTIFS(R2C1:R567827C1,RC6,R2C4:R567827C4,R1C)"
    Range("I2").Select
    Selection.AutoFill Destination:=Range("I2:I249274")
    Range("I2:I249274").Select
With Application
   .ScreenUpdating = True
   .Calculation = xlCalculationAutomatic
End With


End Sub

 

[mhrcvk]

 Sub ÇOKEĞERSAY()
With Application
   .ScreenUpdating = False
   .Calculation = xlCalculationManual
End With

    ActiveCell.FormulaR1C1 = "=COUNTIFS(R2C1:R567827C1,RC6,R2C4:R567827C4,R1C)"
    Range("I2").Select
    Selection.AutoFill Destination:=Range("I2:I249274")
    Range("I2:I249274").Select
With Application
   .ScreenUpdating = True
   .Calculation = xlCalculationAutomatic
End With


End Sub

Kardeşim destek için teşekkür ederim ama yine aynı süre olarak birşey farketmiyor.

Örnek dosyayıda ek olarak ekledim formül ile birlikte fakat bu şekilde işlem çok uzun sürüyor bir kısa yolu var mıdır acaba ?

 

[mhrcvk]

Konu biraz acil arkadaşlar yardımcı olabilecek var mıdır ?

 

[PLİNT]

Merhaba
Şöyle denermisiniz?

 Application.Calculation = xlCalculationManual
    ActiveCell.FormulaR1C1 = "=COUNTIFS(R2C1:R567827C1,RC6,R2C4:R567827C4,R1C)"
     Application.Calculation = xlCalculationAutomatic

    
Range("I2:I249274").FormulaR1C1 = Range("I2").FormulaR1C1
    Range("I2:I249274").Select
Application.Calculation = xlCalculationAutomatic

 

[mhrcvk]

Merhaba
Şöyle denermisiniz?

 Application.Calculation = xlCalculationManual
    ActiveCell.FormulaR1C1 = "=COUNTIFS(R2C1:R567827C1,RC6,R2C4:R567827C4,R1C)"
     Application.Calculation = xlCalculationAutomatic

    
Range("I2:I249274").FormulaR1C1 = Range("I2").FormulaR1C1
    Range("I2:I249274").Select
Application.Calculation = xlCalculationAutomatic

İlgiliniz için çok teşekkür ederim fakat hızlanmıyor. Malesef çektim formülü aşağı doğru bekliyorum artık.

 

[Korhan Ayhan]

Çok satırlı tablolarda formül kullanmak akıllıca değildir.

Bence ÖZET TABLO kullanın. Çok hızlı sonuç alabilirsiniz.

 

[Ziynettin]

Çokeğersay için aşağıdaki makroyu çalıştırıyorum fakat çok yavaş işlem yapıyor hızlandırmak için ne yapabilirim yardımcı olabilecek var mı ?

Merhaba,

A, B, C, D hariç diğer sütunları silin. Aşağıdaki kodu çalıştırın. Verileriniz listelenecektir. İstediğiniz bu durumda ise bende 20 sn. sürüyor. Umarım işinize yarar.

Sub mükerrer_ifade_say()
Dim a(), b(), d1 As Object, d2 As Object
Dim Sat As Long, Sut As Long, Say1 As Long, Say2 As Long, i As Long
Dim n As Long, v(), k
Z = TimeValue(Now)
With Sheets("Sayfa1")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Sat = 1: Sut = 1: Say1 = Sat: Say2 = Sut
a = .Range("A2:D" & .Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        krt = a(i, 2) & "|" & a(i, 3)
        If d1.exists(krt) Then
            Sat = d1(krt)
        Else
            d1(krt) = Say1
            Sat = Say1
            Say1 = Say1 + 1
        End If
        If d2.exists(a(i, 4)) Then
            Sut = d2(a(i, 4))
        Else
            d2(a(i, 4)) = Say2
            Sut = Say2
            Say2 = Say2 + 1
        End If
        ReDim Preserve b(1 To UBound(a), 1 To d2.Count)
        b(Sat, Sut) = b(Sat, Sut) + 1
    Next i
    
    ReDim v(1 To d1.Count, 1 To 3)
    For Each k In d1.keys
        n = n + 1
        v(n, 1) = Replace(k, "|", ".")
        v(n, 2) = Split(k, "|")(0)
        v(n, 3) = Split(k, "|")(1)
    Next k
    
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
        .Range("F1", .Cells(Rows.Count, Columns.Count)).ClearContents
        .Range("F2").Resize(d1.Count, 3) = v
        .Range("i1").Resize(, d2.Count) = d2.keys
        .Range("i2").Resize(d1.Count, d2.Count) = b
    End With
     Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam. :  " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[Merhum İdris SERDAR]

.

Korhan beyin dediği gibi, Pivot Table daha uygun görünüyor.

Table ve Pivot table ile dosyanız yapılmıştır.

http://s9.dosya.tc/server2/bkzqfm/Test2.rar.html


.

 

[antonio]

"dosya.tc" ve diğer upload sitelerine internet erişimim yok.
Forumda dosya yükleme yetkisi bulunanlar tarafından örnek dosya yüklenirse sevinirim.