Düşeyara makro neden uzun sürüyor

[achil19]

Herkese nerhabalar,
düşeyara makrosu hakkında bir şey sormak istiyordum
Aşağıdaki linkteki dosya için bir makro yazdım.
Fakat makro çok uzun sürede geliyor
nedeni nedir acaba?
888 satır için uygulanan bir makro, bunu 30.000 satırlık bir tabloya uygulayacağım.
Normalde düşeyara formülünü kullandığımda 75 dakika falan sürüyordu. Makro ile yaklaşık 15 dakika sürüyor.
Bunu daha kısaltabilir miyim

Bir şey daha soracaktım
For X = 2 To Sheets("Takviye").Cells(Rows.Count, "A").End(3).Rows yerine ilk olarak For X = 2 To Sheets("Takviye").Cells(Rows.Count, "M").End(3).Rows yazmıştım. Bu şekilde hiç değer getirmedi. Nedeni nedir acaba
Herkese çok teşekkürler

Sub DENEME()
On Error Resume Next
For X = 2 To Sheets("Takviye").Cells(Rows.Count, "A").End(3).Rows
Sheets("Takviye").Cells(X, "P") = WorksheetFunction.VLookup(Sheets("Takviye").Cells(X, "M"), Sheets("Mağazalar stok").Range("L:M"), 2, 0)
Next X
MsgBox "İşlem Tamamlandı "
End Sub


https://drive.google.com/open?id=0B6jo34yj3V6rc19wRm9FUDcxREU

 

[achil19]

dosya linkini yanlış göndermişim
aşağıdaki gibidir
https://drive.google.com/open?id=0B6jo34yj3V6rNkVLSDBjYlBSbzA

 

[vardar07]

Düşey ara kriteri ve aranan sütunlar yanlış. Aranan refarans kodu diğer sayfada başka yerde olduğu için veri alamazsınız. Ne yapmak istediğinizi yazarmısınız.

 

[achil19]

Merhaba Vardar07 hocam. Aşağıdaki dosya linkinde doğru dosyayı attım. Çalıştırdığımda sonuçlar geliyor. sadece uzun sürüyor.

https://drive.google.com/file/d/0B6jo34yj3V6rNkVLSDBjYlBSbzA/view

Sub DENEME()
On Error Resume Next
For X = 2 To Sheets("Takviye").Cells(Rows.Count, "A").End(3).Rows
Sheets("Takviye").Cells(X, "P") = WorksheetFunction.VLookup(Sheets("Takviye").Cells( X, "M"), Sheets("Mağazalar stok").Range("L:M"), 2, 0)
Next X
MsgBox "İşlem Tamamlandı "
End Sub

 

[systran]

şu şekilde dener misiniz?

Sub DENEME()
On Error Resume Next
[COLOR="red"]application.screeenupdating=false[/COLOR]
For X = 2 To Sheets("Takviye").Cells(Rows.Count, "A").End(3).Rows
Sheets("Takviye").Cells(X, "P") = WorksheetFunction.VLookup(Sheets("Takviye").Cells( X, "M"), Sheets("Mağazalar stok").Range("L:M"), 2, 0)
Next X
[COLOR="Red"]application.screeenupdating=true[/COLOR]
MsgBox "İşlem Tamamlandı "
End Sub

 

[achil19]

Merhaba systran hocam,
Denedim ama hızında bir değişiklik olmadı ne yazık ki
application.screeenupdating ne işe yarıyor acaba, öğrenmek için soruyorum
Çok teşekkürler yardımınız için

 

[systran]

her işlemden sonra ekran tazelenir, bu da işlemciyi yorar,
yazılan kod bunu devre dışı bırakıyor, işlemleri yaparken ekran tazeleme çalışmadığı için işlemci yapması gerek işe odaklanır,
iş bittikten sonra tazeleme tekrar devreye alınır.
hızında bir değişiklik olmadı derken bende 25-30 sn falan sürdü örnek dosya.

 

[Ziynettin]

Merhaba,
Bu kodu deneyiniz.

Option Explicit
Sub duseyara()
Dim S1 As Worksheet, S2 As Worksheet
Dim i As Long, Say As Long, z As Double
Dim a(), b(), c(), d As Object
On Error Resume Next
z = TimeValue(Now)
Set S1 = Sheets("Mağazalar stok"): Set S2 = Sheets("Takviye")
Set d = CreateObject("scripting.dictionary")
a = S1.Range("L2:M" & S1.Cells(Rows.Count, "L").End(3).Row)

For i = 1 To UBound(a): d(a(i, 1)) = a(i, 2): Next i

b = S2.Range("M2:M" & S2.Cells(Rows.Count, "M").End(3).Row)
ReDim c(1 To UBound(b), 1 To 1)

For i = 1 To UBound(b)
    Say = Say + 1
    c(Say, 1) = d(b(i, 1))
Next i
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Range("P2:P" & Rows.Count).ClearContents

If Say > 0 Then
    S2.[P2].Resize(Say) = c
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlandı..." & vbLf & vbLf & "İşlem süreniz : " & _
                    CDate(TimeValue(Now) - z), vbInformation
End Sub

 

[Korhan Ayhan]

Bende hazırlamıştım. Alternatif olsun.

Sub HIZLI_DÜŞEYARA()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Son As Long, Liste(), Zaman As Double
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("Mağazalar stok")
    Set S2 = Sheets("Takviye")
    
    S2.Range("P2:P" & S2.Rows.Count).ClearContents
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Liste = S1.Range("L1:M" & Son).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Liste, 1)
            .Item(Liste(X, 1)) = Liste(X, 2)
        Next
        
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        Liste = S2.Range("M1:P" & Son).Value
        
        For X = 2 To UBound(Liste, 1)
            If .Exists(Liste(X, 1)) Then Liste(X, 4) = .Item(Liste(X, 1))
        Next
    End With
    
    S2.Range("M1:P" & UBound(Liste)).Value = Liste
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    MsgBox "İşleminiz tamamlandı." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[achil19]

Hocam herkese çok teşekkür ederim
Yorumların hepsinden yeni bir şey öğrendim
30.000 satırlık excel dosyasını 37 sn de düşeyara ile tamamladım (formül ile 75 dak. sürüyordu, makro ile 8 dakika sürüyordu, 37 sn benim için mucize gibi bir şey )
Sn Ziynettin ve Sn Korhan hocalarım sizinki ile daha kısa sürüyor ama bu kadar detaylı makro yazacak düzeyde değilim daha. ezbere iş yapmak istemiyorum, kendi formülü ile yavaş yavaş mantığını anlayarak ilerliyorum

Sn Systran hocamdan application.screeenupdating

Sn Ziyenettin hocamdan z = TimeValue(Now) ve CDate(TimeValue(Now) - z) ile ne kadar sürede tamamlandığını

Sn Koray Ayhan hocamdan with - with end yapısını ve Calculation = xlCalculationAutomatic, EnableEvents = True

mantığını öğrendim

herkese çok teşekkür ederim

 

[cengiz123]

Ziynettin hocam kodunuz gerçekten Harika. Çok hızlı çalışıyor.
Bizim gibiler için çok güzel yol gösteriyorsunuz.teşekkürler

Option Explicit
Sub duseyara()
Dim S1 As Worksheet, S2 As Worksheet
Dim i As Long, Say As Long, z As Double
Dim a(), b(), c(), d As Object
On Error Resume Next
z = TimeValue(Now)
Set S1 = Sheets("Mağazalar stok"): Set S2 = Sheets("Takviye")
Set d = CreateObject("scripting.dictionary")
a = S1.Range("L2:M" & S1.Cells(Rows.Count, "L").End(3).Row)

For i = 1 To UBound(a): d(a(i, 1)) = a(i, 2): Next i

b = S2.Range("M2:M" & S2.Cells(Rows.Count, "M").End(3).Row)
ReDim c(1 To UBound(b), 1 To 1)

For i = 1 To UBound(b)
Say = Say + 1
c(Say, 1) = d(b(i, 1))
Next i
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Range("P2" & Rows.Count).ClearContents

If Say > 0 Then
S2.[P2].Resize(Say) = c
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlandı..." & vbLf & vbLf & "İşlem süreniz : " & _
CDate(TimeValue(Now) - z), vbInformation
End Sub[/CODE]