Mevcut makroyu hızlandırmak

[metin_0606]

Sub listele()
Dim kontrol As Worksheet
Dim tanım As Worksheet
Dim liste As Worksheet

Application.ScreenUpdating = False
Set kontrol = Sheets("KONTROL")
Set liste = Sheets("Liste")
Set tanım = Sheets("GRUP_TANIM")
bukitap = ThisWorkbook.Name
liste.Visible = True
liste.Select
Range(Cells(2, 1), Cells(1000, 20)).ClearContents
kontrolson = kontrol.Cells(Rows.Count, "A").End(xlUp).Row
tanımson = tanım.Cells(Rows.Count, "A").End(xlUp).Row
listeson = liste.Cells(Rows.Count, "A").End(xlUp).Row

For u = 1 To tanımson
    For i = 2 To kontrolson
        sirket = tanım.Cells(u, 1)
        grup = tanım.Cells(u, 2)
        If kontrol.Cells(i, 19) = "IBA ISLETME" Then
                If kontrol.Cells(i, 19) = sirket And kontrol.Cells(i, 20) = grup Then
                kontrol.Select
                Range(Cells(i, 1), Cells(i, 20)).Copy
                liste.Select
                Cells(liste.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End If
        Else
                If kontrol.Cells(i, 19) = sirket Then
                kontrol.Select
                Range(Cells(i, 1), Cells(i, 20)).Copy
                liste.Select
                Cells(liste.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End If
        End If
    Next i
    
    If liste.Cells(2, 2) <> "" Then
    
                If tanım.Cells(u, 2) = Empty Then
                    kitap = tanım.Cells(u, 1) & ".xlsx"
                    dosyayolu = "C:\Users\" & Environ("UserName") & "\Desktop\LISTE\" & tanım.Cells(u, 1) & ".xlsx"
                End If
                If tanım.Cells(u, 2) <> Empty Then
                    kitap = tanım.Cells(u, 1) & "-" & tanım.Cells(u, 2) & ".xlsx"
                    dosyayolu = "C:\Users\" & Environ("UserName") & "\Desktop\LISTE\" & tanım.Cells(u, 1) & "-" & tanım.Cells(u, 2) & ".xlsx"
                End If
                
                liste.Select
                Workbooks.Add
                ActiveWorkbook.SaveAs Filename:=dosyayolu _
                        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                '
                Workbooks(bukitap).Activate
                Sheets("liste").Select
                Sheets("liste").Copy After:=Workbooks(kitap).Sheets(1)
                Workbooks(kitap).Activate
                Sheets("liste").Select
                Application.DisplayAlerts = False
                Sheets("Sayfa1").Delete
                Application.DisplayAlerts = False
                ActiveWorkbook.Save
                ActiveWorkbook.Close
         End If
                Workbooks(bukitap).Activate
                liste.Select
                
                Range(Cells(2, 1), Cells(1000, 20)).ClearContents
  
Next u

kontrol.Select
liste.Visible = 2 - SheetVeryHidden
MsgBox "İşlem Tamamlandı"
End Sub

Arkadaşlar bu makroyu verileri, şirket isimlerine ve gruplarına göre ayırıp masaüstündeki liste isimli klasöre kopyalamada kullanıyorum. Ancak 6000 satırlık veri listesinde kullandığım için yaklaşık 10 dakikada işlemi bitiriyor. Bu zamanı kısaltmak mümkün mü acaba

 

[metin_0606]

Makrolu hali ile örnek dosya

 

[metin_0606]

güncel

 

[metin_0606]

Değerli Arkadaşlar bu makroyu hızlandırma konusunda desteklerinizi beklemekteyim

 

[muratboz06]

Refer to Usage Example on how to use the code.

Public PriorCalcMode As Variant

Public Function TurnOnSpeed(x As Boolean)

'-----------------------------
'Thanks for downloading the code.
'Please visit our channel for a quick explainer on how to use this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Support our channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

    If x = True Then
    With Application
        PriorCalcMode = Application.Calculation
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Cursor = xlWait
            .Calculation = xlCalculationManual
    End With
    
    ElseIf x = False Then
    
    With Application
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
            .StatusBar = False
            .Cursor = xlDefault
        .Calculation = PriorCalcMode
        End With
    End If

End Function

Yeni bir module açın ve yukarıdaki kodları module ekleyin.
Kendi kodunuz da Application.ScreenUpdating = False yazan satırı siliniz ve TurnOnSpeed True yazınız.
Kendi kodunuz da End Sub dan önce TurnOnSpeed False kodunu yazınız.
Umarım faydası olur.

 

[metin_0606]

Refer to Usage Example on how to use the code.

Public PriorCalcMode As Variant

Public Function TurnOnSpeed(x As Boolean)

'-----------------------------
'Thanks for downloading the code.
'Please visit our channel for a quick explainer on how to use this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Support our channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

    If x = True Then
    With Application
        PriorCalcMode = Application.Calculation
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Cursor = xlWait
            .Calculation = xlCalculationManual
    End With
   
    ElseIf x = False Then
   
    With Application
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
            .StatusBar = False
            .Cursor = xlDefault
        .Calculation = PriorCalcMode
        End With
    End If

End Function

Yeni bir module açın ve yukarıdaki kodları module ekleyin.
Kendi kodunuz da Application.ScreenUpdating = False yazan satırı siliniz ve TurnOnSpeed True yazınız.
Kendi kodunuz da End Sub dan önce TurnOnSpeed False kodunu yazınız.
Umarım faydası olur.

Murat bey 6000 kişilik listede 1.dakika 20 sn de işlemi bitirdi çok teşekkür ederim işimi çok kolaylaştırdı.