• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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
 
Örnek dosya üzerinde yapılmak isteneni izah ederseniz; yardım almanız daha da kolaylaşır.
 
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:
Dosyadaki makroyu çalıştıramadım.
Type mishmach hatası veriyor.
 

Ekli dosyalar

  • elitnet1.jpg
    elitnet1.jpg
    146 KB · Görüntüleme: 11
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:
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.
 
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
 
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:
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
 
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. :)
 
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.
 
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
 
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
 
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
 
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
 
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
 
Denedim ama sonuç yine aynı maalesef Korhan bey, Tekrar çok teşekkür ederim
 
Rica ederim. En azından denedik..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst