Makro hızlandırma

kiran67 · 16 Aralık 2020

Merhaba Puantaj sayfasındaki listenin Kontrol sayfasındaki gibi listelenmesini istiyorum. Sicil no, adı soyadı, tarih ve o tarihte girilen veri şeklinde. Puantaj sayfasında makro var kişi sayısı ve gün sayısını girdiğimizde ve makroyu çalıştırdığımızda kontrol sayfasına atıyor. Ancak kişi sayısı çok olduğu için makro çok yavaş çalışıyor. Bunu hızlandırma şansımız var mıdır yada İndis gibi bir formül falan koyabilir miyiz ? Şimdiden teşekkürler iyi çalışmalar dilerim.

https://dosyam.org/1JZ1/MAKRO.rar

Korhan Ayhan · 16 Aralık 2020

Merhaba,

PUANTAJ sayfasında "AM" sütununu kullanıyor musunuz? Bu sütuna puantaj verisi giriyor musunuz?

Korhan Ayhan · 16 Aralık 2020

Sizin kullandığınız kodları incelediğimde dahil etmediğinizi gördüm. Bu sebeple üstte ki sorumu görmezden gelebilirsiniz.

Deneyiniz.

C++:

Option Explicit

Private Sub Kontrol_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Byte, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
   
    Set S1 = Sheets("PUANTAJ")
    Set S2 = Sheets("KONTROL")
   
    S2.Range("A2:E" & S2.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    If Son < 4 Then
        MsgBox "Puantaj sayfasında işlem yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
   
    If Son = 4 Then Son = 5
   
    Veri = S1.Range("A4:AQ" & Son).Value
   
    ReDim Liste(1 To Son * 30, 1 To 5)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 2) <> "" Then
            For Y = 9 To 38
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 2)
                Liste(Say, 2) = Veri(X, 3)
                Liste(Say, 4) = S1.Cells(2, Y)
                Liste(Say, 5) = Veri(X, Y)
            Next
        End If
    Next
   
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 5) = Liste
        S2.Columns.AutoFit
       
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
       
        MsgBox "Veri aktarımı tamamlanmıştır" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
      
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
   
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

kiran67 · 16 Aralık 2020

Korhan Ayhan' Alıntı:

Sizin kullandığınız kodları incelediğimde dahil etmediğinizi gördüm. Bu sebeple üstte ki sorumu görmezden gelebilirsiniz.

Deneyiniz.

C++:

Option Explicit

Private Sub Kontrol_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Byte, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
  
    Set S1 = Sheets("PUANTAJ")
    Set S2 = Sheets("KONTROL")
  
    S2.Range("A2:E" & S2.Rows.Count).ClearContents
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
  
    If Son < 4 Then
        MsgBox "Puantaj sayfasında işlem yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
  
    If Son = 4 Then Son = 5
  
    Veri = S1.Range("A4:AQ" & Son).Value
  
    ReDim Liste(1 To Son * 30, 1 To 5)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 2) <> "" Then
            For Y = 9 To 38
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 2)
                Liste(Say, 2) = Veri(X, 3)
                Liste(Say, 4) = S1.Cells(2, Y)
                Liste(Say, 5) = Veri(X, Y)
            Next
        End If
    Next
  
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 5) = Liste
        S2.Columns.AutoFit
      
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
      
        MsgBox "Veri aktarımı tamamlanmıştır" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
     
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
  
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Gözlerime inanamıyorum. 15 dk dan fazla sürüyordu. 42 saniyede tamamlandı. Elleriniz dert görmesin. Allah razı olsun çok sağolun.

Korhan Ayhan · 16 Aralık 2020

42 saniye sürdüğüne göre veri sayınız baya fazla sanırım.

kiran67 · 16 Aralık 2020

Korhan Ayhan' Alıntı:
42 saniye sürdüğüne göre veri sayınız baya fazla sanırım.

Evet çok fazla veri var. Bu benim için mükemmel sonuç i7 işlemci bilgisayarda 15 dk rahat bekliyordum

Gerçekten çok teşekkür ederim. Bilginin sınırı yok.

kiran67 · 7 Ocak 2021

Korhan Ayhan' Alıntı:
42 saniye sürdüğüne göre veri sayınız baya fazla sanırım.

Ustad merhaba. 31 çeken aylarda problem oluyor. AU2 hücresinde gün sayısı var onu değiştiriyorum 31 yapıyorum ama dikkate almıyor. Yine 30 günlük verileri çekiyor. Müsait olduğunuzda tekrar bakabilir misiniz? Makro çok hızlı ama 11 saniye sürdü

Korhan Ayhan · 7 Ocak 2021

#2 nolu mesajımda aslında bu durumu sormuştum.

kiran67 · 7 Ocak 2021

Korhan Ayhan' Alıntı:
#2 nolu mesajımda aslında bu durumu sormuştum.

Gözden kaçırmışım kusura bakmayın. Yani 31 çeken aylarda giriliyor sadece. Yeni yaptığınız makroda da AU2 sütununun etkisi olmadığını bilmiyordum.

Korhan Ayhan · 7 Ocak 2021

Deneyiniz.

PUANTAJ sayfasında I2:AM2 hücre aralığında dolu (tarih olan) sütunları diğer sayfaya aktaracaktır.

C++:

Private Sub Kontrol_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Byte, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
   
    Set S1 = Sheets("PUANTAJ")
    Set S2 = Sheets("KONTROL")
   
    S2.Range("A2:E" & S2.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    If Son < 4 Then
        MsgBox "Puantaj sayfasında işlem yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
   
    If Son = 4 Then Son = 5
   
    Veri = S1.Range("A4:AQ" & Son).Value
   
    ReDim Liste(1 To Son * 31, 1 To 5)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 2) <> "" Then
            For Y = 9 To 39
                If S1.Cells(2, Y) <> "" Then
                    Say = Say + 1
                    Liste(Say, 1) = Veri(X, 2)
                    Liste(Say, 2) = Veri(X, 3)
                    Liste(Say, 4) = S1.Cells(2, Y)
                    Liste(Say, 5) = Veri(X, Y)
                End If
            Next
        End If
    Next
   
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 5) = Liste
        S2.Columns.AutoFit
       
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
       
        MsgBox "Veri aktarımı tamamlanmıştır" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
      
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
   
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

kiran67 · 7 Ocak 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

PUANTAJ sayfasında I2:AM2 hücre aralığında dolu (tarih olan) sütunları diğer sayfaya aktaracaktır.

C++:

Private Sub Kontrol_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Byte, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
  
    Set S1 = Sheets("PUANTAJ")
    Set S2 = Sheets("KONTROL")
  
    S2.Range("A2:E" & S2.Rows.Count).ClearContents
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
  
    If Son < 4 Then
        MsgBox "Puantaj sayfasında işlem yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
  
    If Son = 4 Then Son = 5
  
    Veri = S1.Range("A4:AQ" & Son).Value
  
    ReDim Liste(1 To Son * 31, 1 To 5)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 2) <> "" Then
            For Y = 9 To 39
                If S1.Cells(2, Y) <> "" Then
                    Say = Say + 1
                    Liste(Say, 1) = Veri(X, 2)
                    Liste(Say, 2) = Veri(X, 3)
                    Liste(Say, 4) = S1.Cells(2, Y)
                    Liste(Say, 5) = Veri(X, Y)
                End If
            Next
        End If
    Next
  
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 5) = Liste
        S2.Columns.AutoFit
      
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
      
        MsgBox "Veri aktarımı tamamlanmıştır" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
     
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If
  
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Çalıştı. Çok teşekkürler elinize sağlık

Makro hızlandırma

kiran67

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

kiran67

Korhan Ayhan

Administrator

kiran67

kiran67

Korhan Ayhan

Administrator

kiran67

Korhan Ayhan

Administrator

kiran67