Makro kodunu nasıl hızlandıra bilirim?

[blazer2004]

Merhaba arkadaslar saygideger hocalarim asagidaki Makro10596 satirda Kayit ariyor ve sonuc 4 saat suruyor.bunu daha hizli yapabilmem icin makroyu Nasil degistiririm yardimci olurmusunuz.Simdiden herkese Tesekkurler.


Sub kod()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
*
yol = ThisWorkbook.Path & "\eski.xlsx"
Workbooks.Open (yol)
For i = 6 To Workbooks("Eski").Sheets("sat").Range("A65536").End(3).Row
For a = 5 To 16
For k = 2 To Workbooks("yeni").Sheets("ALIM").Range("A65536").End(3).Row
*
*
If Workbooks("yeni").Sheets("ALIM").Cells(k, "A") = Workbooks("Eski").Sheets("BPO").Cells(i, "A") And Format(Workbooks("yeni").Sheets("ALIM").Cells(k, "D"), "mmmm") = Format(Workbooks("Eski").Sheets("sat").Cells(2, a), "mmmm") Then
*
Workbooks("yeni").Sheets("ALIM").Cells(k, 2) = Workbooks("Eski").Sheets("sat").Cells(i, a)
*
End If
Next k
Next a
Next i
*
Workbooks("Eski").Close True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
*
End Sub

 

[Korhan Ayhan]

Örnek dosyalarınızı paylaşım sitelerine ekleyip link verirseniz daha hızlı yanıt alırsınız.

 

[blazer2004]

Merhaba,
dosyam ekte'dir.Yardımlarınız için çok teşekkürler.


http://www.upload.gen.tr/d.php/www/5WN1v/yeni-klasor.7z.html

 

[PLİNT]

Merhaba
Ek dosyayı deneyin eksiklik çıkarsa gidermeye çalışalım.
http://s2.dosya.tc/server3/fqp730/Yeni_klasor.zip.html

[SIZE="2"]Sub kod()
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
yol = ThisWorkbook.Path & "\PARCA_FIYATLARI_2016 (2).xlsx"
Workbooks.Open (yol)
Set x = ThisWorkbook.Sheets("B-PLAS ALIM")
Set xx = Workbooks("PARCA_FIYATLARI_2016 (2)").Sheets("BPO")
xr = x.Range("A65536").End(3).Row
xxr = xx.Range("A65536").End(3).Row
x.Range("B2:B" & xr) = Empty
ThisWorkbook.Activate
For k = 2 To xr
 Set c = xx.Range("a5:a" & xxr).Find(x.Cells(k, "A"), LookIn:=xlValues)
 If Not c Is Nothing Then
  For a = 5 To 16
If Format(x.Cells(k, "D"), "mmmm") = Format(xx.Cells(2, a), "mmmm") Then
  x.Cells(k, 2).Select
 x.Cells(k, 2) = xx.Cells(c.Row, a)
 End If
Next
 End If
 Next [/SIZE]

 

[blazer2004]

Sayın Point elinize sağlık cok guzel olmus.Başarılarınızın devamını dilerim.