Puantaj Ay Seçince Yavaşlaması

[mukoli]

Merhaba hocalarım ekteki dosyada ay seçince hücrelere otomatik X ve O yazmaktadır. Fazla kişi olunca makro bekletiyor daha hızlı yapılabilirmi .Desteğiniz için teşekkürler

 

[1Al2Ver]

Merhaba,

Kod'a aşağıdaki ilaveleri yapıp denedim, siz bu işlemi ne kadar zamanda yaptığınızı belirtmemişsiniz, bu nedenle karşılaştırma yapamadım,

Ek'li dosyanızdaki kişi sayısına (50 kişi) ve Haziran ayına göre, işlem, 12:35 saniye (13 saniyeden az) sürdü,

Bilgisayarım ; Intel(R) Core(TM) i5-2450M CPU @ 2.50GHz , 64 bit ve 6 RAM

Umarım doğru çözüm olmuştur.

KOD ;
.........................................
Range("h8:al57").ClearContents

Application.Calculation = xlCalculateManual

günn = 1

...........................
...........................

End If

Application.Calculation = xlCalculationAutomatic

End Sub

 

[mukoli]

MErhaba hocam teşekkür ederim öncelikle 50 kişide bu şekilde bendede 15 saniye sürüyor . 150 personel olucak ozman daha cok beklecetek sizin dediğiniz yöntemi deniyorum hemen

 

[mukoli]

Bu şekilde denediğimde yine 15 saniye bekletti

 

[1Al2Ver]

Merhaba,

Belki de farklı bir teknikle yeni bir kod yazmak gerekiyordur,.

Konusunda uzman arkadaşlar ilgilenirler sanırım,

Teşekkür ederim.

 

[mukoli]

Teşekkür ediyorum ilginize

 

[mukoli]

Çözümü olan varmıdır

 

[Saban Sertkaya]

Dosyanızı alternatif bir linke yükleyebilir misiniz. Yardımcı olabilir miyiz bir bakalım.

 

[mukoli]

Merhaba
Dosya indir

 

[mukoli]

Varmı yardımcı olucak arkadaşlar

 

[Korhan Ayhan]

Deneyiniz.

Hızdan yangın çıkacak...

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim Last_Row As Long, Rng As Range
    Dim My_Date As Variant, My_Day As Byte
    
    If Intersect(Target, Range("C3:C4")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Last_Row = Cells(Rows.Count, 3).End(3).Row
    
    Range("H5:AL" & Last_Row).ClearContents
    
    My_Date = DateSerial(Range("C4").Value, Range("A3").Value, 1)
    
    Range("H6").Value = My_Date
    
    My_Day = Day(WorksheetFunction.EoMonth(CLng(My_Date), 0))
    
    Range("H6").AutoFill Destination:=Range("H6").Resize(, My_Day), Type:=xlFillDefault

    With Range("H5:AL5")
        .Formula = "=IF(H6="""","""",DAY(H6))"
        .Value = .Value
    End With
    
    With Range("H7:AL7")
        .Formula = "=IF(H6="""","""",TEXT(H6,""ggg""))"
        .Value = .Value
    End With
    
    For Each Rng In Range("H6:AL6")
        If Rng.Value <> "" Then
            If Weekday(Rng.Value, vbMonday) = 7 Then
                Cells(8, Rng.Column).Resize(Last_Row - 7) = "O"
            Else
                Cells(8, Rng.Column).Resize(Last_Row - 7) = "X"
            End If
        End If
    Next
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[mukoli]

Korhan hocam siz süpersiniz. Kod görevini yerine getiriyor süper hızlı fakat hücrede değişiklik yapamıyorum . H8 ile AL arasına manuel müdahale etmem gerekiyor o şekilde olursa süper olur

 

[Korhan Ayhan]

Koda küçük bir ekleme yaptım. Deneyiniz.

 

[mukoli]

Elinize yüreginize sağlık hocam çok sağolun