Vba Kod Yavaş Çalışıyor Yardım

[mkoray7]

Merhabalar Kolay Gelsin,

Aşağıda belirtiğim şekilde bir kod kullanıyorum ancak kod örnekte 3 personel ile çalıştığımda çok yavaş çalışıyor hızlandırmak için bir öneriniz olursa sevinirim.

Kolay gelsin iyi Çalışmalar.

Private Sub CommandButton1_Click()



Dim k, i As Integer



Application.CutCopyMode = False

Application.ScreenUpdating = False





i = 12



Do Until Sheets("PuantajGiriş").Cells(i, 2) = ""





k = 5



    Do Until Sheets("PuantajGiriş").Cells(11, k) = ""

    

    

    Sheets("KontrolPaneli").Rows(2).Insert

    

    'Tarihleri kopyala

    Sheets("PuantajGiriş").Cells(11, k).Copy

    Sheets("KontrolPaneli").Cells(2, 1).PasteSpecial xlPasteValues

    Sheets("KontrolPaneli").Cells(2, 1).NumberFormat = "dd.mm.yyyy"

    

     'Durumları Kopyala

    Sheets("PuantajGiriş").Cells(i, k).Copy

    Sheets("KontrolPaneli").Cells(2, 3).PasteSpecial xlPasteValues

    

     'İsmi Kopyala

    Sheets("PuantajGiriş").Cells(i, 3).Copy

    Sheets("KontrolPaneli").Cells(2, 2).PasteSpecial xlPasteValues

    

    k = k + 1

    

    Loop

    

    i = i + 1

    

Loop



MsgBox "Kayıtlar Kayıt Edilmiştir.Yeni Aya Geçebilirsiniz.", vbInformation, "Bilgilendirme"



ThisWorkbook.RefreshAll



Application.CutCopyMode = True

Application.ScreenUpdating = True





End Sub

 

[Muzaffer Ali]

Merhaba.

Böyle deneyin.
Eğer yeterli hızlanma olmazsa dosyanızı ekleyin kontrol edelim.
Dosyanızı dosya.co gibi bir siteye ekleyerek paylaşabilirsiniz

Private Sub CommandButton1_Click()
    Dim k, i As Integer
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    i = 12
    Do Until Sheets("PuantajGiriş").Cells(i, 2) = ""
        k = 5
        Do Until Sheets("PuantajGiriş").Cells(11, k) = ""
            Sheets("KontrolPaneli").Rows(2).Insert
            'Tarihleri kopyala
            Sheets("KontrolPaneli").Cells(2, 1) = Sheets("PuantajGiriş").Cells(11, k)
            Sheets("KontrolPaneli").Cells(2, 1).NumberFormat = "dd.mm.yyyy"
             'Durumları Kopyala
            Sheets("KontrolPaneli").Cells(2, 3) = Sheets("PuantajGiriş").Cells(i, k)
             'İsmi Kopyala
            Sheets("KontrolPaneli").Cells(2, 2) = Sheets("PuantajGiriş").Cells(i, 3)
            k = k + 1
        Loop
        i = i + 1
    Loop
    MsgBox "Kayıtlar Kayıt Edilmiştir.Yeni Aya Geçebilirsiniz.", vbInformation, "Bilgilendirme"
    ThisWorkbook.RefreshAll
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
End Sub

 

[mkoray7]

Merhabalar Cevabınız için teşekkür ederim
Dosyanın indirme linki
https://dosya.co/p8lx2dsok8dt/Personel_TakipMakro_.xlsm.html
Kolay Gelsin,

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Private Sub CommandButton1_Click()
    Dim Gun As Integer
    Dim syfPuantaj As Worksheet
    Dim syfKontrol As Worksheet
    Dim Bak As Long
    
    Set syfKontrol = Worksheets("KontrolPaneli")
    Set syfPuantaj = Worksheets("PuantajGiriş")
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Bak = 10
    Gun = Day(WorksheetFunction.EoMonth(Range("C7"), 0))
    
    Do Until syfPuantaj.Cells(Bak + 1, "C") = ""
    
        Bak = Bak + 1
        syfKontrol.Rows("2:" & Gun + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        syfPuantaj.Range("E10:" & Cells(10, Gun + 4).Address).Copy
        syfKontrol.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        syfKontrol.Range("B2:B" & Gun + 1).Value = syfPuantaj.Cells(Bak, "C").Value
        syfPuantaj.Range("E" & Bak & ":" & Cells(Bak, Gun + 4).Address).Copy
        syfKontrol.Range("C2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Loop
    
    syfKontrol.Range("A:A").NumberFormat = "m/d/yyyy"
    
    MsgBox "Kayıtlar Kayıt Edilmiştir.Yeni Aya Geçebilirsiniz.", vbInformation, "Bilgilendirme"
    
    ThisWorkbook.RefreshAll
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub