Makro İşlem Süresi Hızlandırma

O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Merhaba,
116 sütun ve 2999 satır olmak üzere toplam 347884 hücrede işlem yapıyorum. Makroda herhangi bir sıkıntı yok çalışıyor ancak işlem çok uzun sürüyor.
Kodlamada bu süreyi kısaltabilecek bir düzenleme yapabilir miyiz?

Kod: 
Sub iletim()
 Application.Calculation = xlManual
 Application.ScreenUpdating = False
 Dim a As Long, B As Long
 For a = 6 To 3005
 If Left(Cells(a, 1), 2) <> 0 Then
    For B = 8 To 124
    If Left(Cells(a, 2), 2) = "DH" Or Left(Cells(a, 2), 2) = "CC" Or Left(Cells(a, 2), 2) = "CA" Or Left(Cells(a, 2), 2) = "TG" Then
    Cells(a, B) = (WorksheetFunction.Index(Sheets("veri").Range("AI3:AU252"), WorksheetFunction.Match(Cells(a, 2) & Cells(a, 3), Sheets("veri").Range("AH3:AH252"), 0), Cells(2, B) - 5) + (26.7 - Cells(a, 7)) + (Cells(5, B) - 29.45)) * Cells(a, 4) * Cells(a, 5)
    ElseIf Left(Cells(a, 2), 2) = "DP" Or Left(Cells(a, 2), 2) = "DK" Or Left(Cells(a, 2), 2) = "BK" Then
    Cells(a, B) = (Cells(3, B) - Cells(a, 7)) * Cells(a, 4) * Cells(a, 5)
    ElseIf Left(Cells(a, 2), 2) = "DO" Or Left(Cells(a, 2), 2) = "İD" Or Left(Cells(a, 2), 2) = "TO" Or Left(Cells(a, 2), 2) = "İT" Then
    Cells(a, B) = (Cells(3, B) - Cells(a, 7) + Cells(a, 6)) * Cells(a, 4) * Cells(a, 5)
    Else
    Cells(a, B) = ""
    End If
    Next B
 End If
 Next a
 Application.Calculation = xlAutomatic
 Application.ScreenUpdating = True
End Sub
Saygılarımla
 
Murat OSMA

Murat OSMA

Altın Üye
Altın Üye
Katılım
23 Mayıs 2011
Mesajlar
5,508
Excel Vers. ve Dili
Microsoft 365 TR-EN
Altın Üyelik Bitiş Tarihi
31-12-2028
Örnek dosya üzerinde yapılmak isteneni izah ederseniz; yardım almanız daha da kolaylaşır.
 
O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Murat Bey merhaba,
Örnek dosyayı ekledim.
Örnek Dosya
İletim sayfasında A6 ve G6 arasındaki veriler ve H5 ve DT5 arasındaki verileri kullanarak ilgili hücrelere hesaplamalar yapılıyor.

Bilgi: Sistem kastığı için hesaplamayı görmek adına "No" sütunu kısmında 10 dan sonrakileri 0 yapıp makroyu çalıştırırsanız yapılan hesaplama görülebilir.
 
Son düzenleme:
Murat OSMA

Murat OSMA

Altın Üye
Altın Üye
Katılım
23 Mayıs 2011
Mesajlar
5,508
Excel Vers. ve Dili
Microsoft 365 TR-EN
Altın Üyelik Bitiş Tarihi
31-12-2028
Dosyadaki makroyu çalıştıramadım.
Type mishmach hatası veriyor.
 

Ekli dosyalar

O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Murat Bey, kodlar bende çalışıyor işlem uzun sürmesinden dolayı belki kaynaklanabilir.
No sütununda, A17 den itibaren A3005 e kadar 0 olarak atayın. A6-A16 arasındaki değerleri hesaplasın. En azından çalıştığını görebilirsiniz.
Ayrıca, şimdi süre tuttum hepsi 50.3 sn de hesaplanıyor. :)
 
Son düzenleme:
O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Murat Bey, izledim neden hata veriyor anlamadım. Başka bilgisayarlarda denedim kodlar çalıştı. Sağlık olsun artık. İlginiz için teşekkürler.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,243
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosyanızdaki hatanın sebebi "veri" sayfasında kullandığınız kullanıcı tanımlı fonksiyondur. Bu fonksiyonu dosyanıza eklemediğiniz için bizlerde hata veriyor.

Aşağıdaki kod ile 15 saniyede sonuç alabildim.

Kod: 
Sub iletim()
    Dim a As Long
    
    zaman = Timer
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Sheets("iletim").Range("h6:dt" & Rows.Count).Clear
    
    For a = 6 To 3005
        If Left(Cells(a, 1), 2) <> 0 Then
            Range("h" & a & ":dt" & a).FormulaR1C1 = "=IF(OR(LEFT(RC2,2)=""DH"",LEFT(RC2,2)=""CC"",LEFT(RC2,2)=""CA"",LEFT(RC2,2)=""TG""),(INDEX(veri!R3C35:R252C47,MATCH(RC2&RC3,veri!R3C34:R252C34,0),R2C-5)+(26.7-RC7)+(R5C-29.45))*RC4*RC5,IF(OR(LEFT(RC2,2)=""DP"",LEFT(RC2,2)=""DK"",LEFT(RC2,2)=""BK""),(R3C-RC7)*RC4*RC5,IF(OR(LEFT(RC2,2)=""DO"",LEFT(RC2,2)=""İD"",LEFT(RC2,2)=""TO"",LEFT(RC2,2)=""İT""),(R3C-RC7+RC6)*RC4*RC5,"""")))"
            Range("h" & a & ":dt" & a).Value = Range("h" & a & ":dt" & a).Value
        End If
    Next a
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşlem süresi ; " & Format((Timer - zaman), "0.00")
End Sub
 
O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Korhan Bey, teşekkür ederim, işlem süresi belirttiğiniz gibi 15 sn içerisinde tamamlanıyor.

Bilgi: Ktf kaynaklı hata veren dosya linkini düzenledim.
İyi Günler.
 
Son düzenleme:
O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Kodlamada başka bir düzenleme ile işlem süresi 7 sn ye düştü. Bu şekilde 4 farklı hesaplama modülü var, toplam 28-30 sn sürüyor. Biraz daha düşürülebilirse çok daha iyi olacak.
Kod: 
Sub iletim()
    Dim a                     As Long
    Dim B                     As Long
    Dim RowData
    Dim ColumnData
    Dim DataOut(1 To 3000, 1 To 117)
    Dim RowMatch
    Application.Calculation = xlManual
    Application.ScreenUpdating = False

    RowData = Range("A6:G3005").Value2
    ColumnData = Range("H2:DT5").Value2
    For a = 1 To 3000
        If Left(RowData(a, 1), 2) <> 0 Then
            RowMatch = Application.Match(RowData(a, 2) & RowData(a, 3), Sheets("veri").Range("AH3:AH252"), 0)
            For B = 1 To 117
                Select Case Left(RowData(a, 2), 2)
                    Case "DH", "CC", "CA", "TG"
                        DataOut(a, B) = (WorksheetFunction.Index(Sheets("veri").Range("AI3:AU252"), RowMatch, ColumnData(1, B) - 5) + (26.7 - RowData(a, 7)) + (ColumnData(4, B) - 29.45)) * RowData(a, 4) * RowData(a, 5)
                    Case "DP", "DK", "BK"
                        DataOut(a, B) = (ColumnData(2, B) - RowData(a, 7)) * RowData(a, 4) * RowData(a, 5)
                    Case "DO", "İD", "TO", "İT"
                        DataOut(a, B) = (ColumnData(2, B) - RowData(a, 7) + RowData(a, 6)) * RowData(a, 4) * RowData(a, 5)
                    Case Else
                        DataOut(a, B) = ""
                End Select
            Next B
        End If
    Next a

    Range("H6:DT3005").Value2 = DataOut
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,243
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Döngü olduğu için işlem uzun sürüyor. En son eklediğiniz kodlamada döngü olarak yazılabilecek en hızlı kodlamadır.

Ayrıca belirttiğiniz süre çok uzun değil.

30 Saniye beklemeye bile tahammülüm yok diyorsunuz. :)
 
O

ofd2008

Katılım
16 Temmuz 2013
Mesajlar
87
Excel Vers. ve Dili
2010
Korhan Bey, insanoğlu hep daha fazlasını istiyor, dediğiniz gibi aslında en iyisi buysa artık elindekiyle yetinmek lazım :)
Yardımlarınız için teşekkür ederim.
 
K

Kumpasta

Katılım
28 Nisan 2016
Mesajlar
181
Excel Vers. ve Dili
2010
Altın Üyelik Bitiş Tarihi
06-01-2024
Böyle bir kaç saniye daha hızlanabilir diye ümit ediyorum
C++: 
Sub iletim()
Dim a As Long
Dim B As Long
Dim RowData As Variant
Dim ColumnData As Variant
Dim DataOut As Variant
Dim RowMatch As Variant
Application.Calculation = xlManual
Application.ScreenUpdating = False

RowData = Range("A6:G3005").Value2
ColumnData = Range("H2:DT5").Value2
ReDim DataOut(1 To UBound(RowData, 1), 1 To UBound(ColumnData, 2))
For a = 1 To UBound(RowData, 1)
    If Left(RowData(a, 1), 2) <> 0 Then
        RowMatch = Application.Match(RowData(a, 2) & RowData(a, 3), Sheets("veri").Range("AH3:AH252"), 0)
        For B = 1 To UBound(ColumnData, 2)
            Select Case Left(RowData(a, 2), 2)
                Case "DH", "CC", "CA", "TG"
                    DataOut(a, B) = (WorksheetFunction.Index(Sheets("veri").Range("AI3:AU252"), RowMatch, ColumnData(1, B) - 5) + (26.7 - RowData(a, 7)) + (ColumnData(4, B) - 29.45)) * RowData(a, 4) * RowData(a, 5)
                Case "DP", "DK", "BK"
                    DataOut(a, B) = (ColumnData(2, B) - RowData(a, 7)) * RowData(a, 4) * RowData(a, 5)
                Case "DO", "İD", "TO", "İT"
                    DataOut(a, B) = (ColumnData(2, B) - RowData(a, 7) + RowData(a, 6)) * RowData(a, 4) * RowData(a, 5)
                Case Else
                    DataOut(a, B) = vbNullString
            End Select
        Next B
    End If
Next a

Range("H6:DT3005").Value2 = DataOut
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
 
P

petsiye

Altın Üye
Katılım
28 Eylül 2009
Mesajlar
145
Excel Vers. ve Dili
Office 2019 TR 32 Bit
Altın Üyelik Bitiş Tarihi
10-05-2029
Merhaba,

Bende bu filtreleme kodları çok yavaş çalışıyor. Manuel aynı şekilde yaptığım filtre oldukça hızlı. Yardımcı olabilecek var ise çok sevinirim. Teşekkür ederim.


Sub BUNUSIL()
'
' BUNUSIL Makro
'

'
Range("AO3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range("$A$2:$VD$5001").AutoFilter Field:=41, Criteria1:=RGB(0, _
0, 0), Operator:=xlFilterCellColor
With ActiveSheet.AutoFilter.Filters(41).Criteria1
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
With ActiveSheet.AutoFilter.Filters(41).Criteria1.Gradient.ColorStops.Add(0)
.Color = 16777215
.TintAndShade = 0
End With
With ActiveSheet.AutoFilter.Filters(41).Criteria1.Gradient.ColorStops.Add(1)
.Color = 0
.TintAndShade = 0
End With
Range("AO4").Select
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,243
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Genel olarak aşağıdaki kodlama tekniği makroları hızlandırmaktadır.

Deneyiniz hızlanma olmazsa örnek dosya paylaşırsanız yardımcı olmak isteyenler denemeler yaparak size destek verebilirler..

C++: 
Option Explicit

Sub Test()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Rem Kodlarınız...
    Rem Kodlarınız...
    Rem Kodlarınız...
    Rem Kodlarınız...
    Rem Kodlarınız...
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
P

petsiye

Altın Üye
Katılım
28 Eylül 2009
Mesajlar
145
Excel Vers. ve Dili
Office 2019 TR 32 Bit
Altın Üyelik Bitiş Tarihi
10-05-2029
Cevabınız için teşekkür ederim Korhan bey, Denedim ama gözle görülür bir hız elde edemedim maalesef. Söz konusu dosyamı özel sebeplerden dolayı paylaşamıyorum maalesef kusuruma bakmayın lütfen. Yardımcı olmaya çalıştığınız için tekrar teşekkür ederim. Saygılarımla
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,243
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki satırlar gereksiz gibi görünüyor. Silip deneme yapabilirsiniz. Belki faydası olabilir..

Range("AO3").Select
Range(Selection, Selection.End(xlDown)).Select
 
P

petsiye

Altın Üye
Katılım
28 Eylül 2009
Mesajlar
145
Excel Vers. ve Dili
Office 2019 TR 32 Bit
Altın Üyelik Bitiş Tarihi
10-05-2029
Denedim ama sonuç yine aynı maalesef Korhan bey, Tekrar çok teşekkür ederim
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,243
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Rica ederim. En azından denedik..
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst