Mevcut makroyu hızlandırma

[metin_0606]

Hangi alanda formül var. Detayları vermezseniz nasıl çözüm bulacağız.

Ana sayfada V ve U sütunlarında hocam

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Liste As Variant, X As Long, Zaman As Double
    Dim Tc_Bul As Range, Son As Long, Y As Byte, Baslik As Range
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
    
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Liste = S1.Range("A2:Y" & Son).Value
    
    For X = 1 To UBound(Liste)
        If Liste(X, 23) = "Etkin" Then
            Set Tc_Bul = S2.Range("A:A").Find(Liste(X, 2), , , xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 2 To S2.Cells(1, Columns.Count).End(1).Column
                    If WorksheetFunction.CountA(S2.Columns(Y)) - 1 > 0 Then
                        Set Baslik = S1.Rows(1).Find(S2.Cells(1, Y), , , xlWhole)
                        If Not Baslik Is Nothing Then
                            Liste(X, Baslik.Column) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    Application.Index(S1.Range("W2:Y" & UBound(Liste) + 1), , 1) = Application.Index(Liste, , 23)
    Application.Index(S1.Range("W2:Y" & UBound(Liste) + 1), , 2) = Application.Index(Liste, , 24)
    Application.Index(S1.Range("W2:Y" & UBound(Liste) + 1), , 3) = Application.Index(Liste, , 25)
    
    ReDim Preserve Liste(1 To UBound(Liste), 1 To 20)
    S1.Range("A2:T" & UBound(Liste) + 1) = Liste
    
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[metin_0606]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Liste As Variant, X As Long, Zaman As Double
    Dim Tc_Bul As Range, Son As Long, Y As Byte, Baslik As Range
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
   
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Liste = S1.Range("A2:Y" & Son).Value
   
    For X = 1 To UBound(Liste)
        If Liste(X, 23) = "Etkin" Then
            Set Tc_Bul = S2.Range("A:A").Find(Liste(X, 2), , , xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 2 To S2.Cells(1, Columns.Count).End(1).Column
                    If WorksheetFunction.CountA(S2.Columns(Y)) - 1 > 0 Then
                        Set Baslik = S1.Rows(1).Find(S2.Cells(1, Y), , , xlWhole)
                        If Not Baslik Is Nothing Then
                            Liste(X, Baslik.Column) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
   
    ReDim Preserve Liste(1 To UBound(Liste), 1 To 20)
    S1.Range("A2:T" & UBound(Liste) + 1) = Liste
   
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan hocam sizi çok ugrastirdim hakkınızı helal edin bu şekilde kodu calistirdigimda örneğin Ana sayfadaki grupları guncelleyemiyorum sanırım T sütununa kadar sınırlama var

 

[Korhan Ayhan]

Merhaba,

#22 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

Not : @Haluk beye katkısından dolayı çok teşekkür ederim.