Soru Bu kodu daha pratik bir hale getirmek mümkün mü?

[seckinb]

Merhaba,
500-1000 dosyayı bir yerden bir yere for - next ile kopyalıyorum.

Acaba bu kullandığım kodun hızını arttırmak mümkün mü?

Sub Auto_mod()

Dim w1 As Workbook

Dim w2 As Workbook
Dim w3 As Workbook
Dim k2 As Worksheet
Dim k3 As Worksheet
Dim i As Integer

Dim path As String
Dim fn1 As String

ChDir "D:\EDU\TRT\SABLONLAR"

fname1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls?", , "yeni - hedef dosyayı seçelim")
If fname1 = "False" Then Exit Sub


Set w1 = ThisWorkbook
'Set w1 = Workbooks("TATE-24-3-2020.xlsm")
Dim LR As Long

LR = w1.Worksheets("kaynak").Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To LR

fname = w1.Worksheets("kaynak").Range("a" & i).Value

'fname = Application.GetOpenFilename("Excel Files (*.xls*), *.xls?", , "eski - kaynak dosyayı seçelim")
If fname = "False" Then Exit Sub


Set w2 = Workbooks.Open(fname)
Set w3 = Workbooks.Open(fname1)
    'şablon için fname1 yani w3 kullanılıyor.

Set k2 = w2.Worksheets("kimlik")
Set k3 = w3.Worksheets("kimlik")

w2.Activate

For Each sh In Worksheets
    sh.Unprotect "sb123"
Next

ActiveSheet.Cells.UnMerge

w2.Worksheets("kanlar").Range("A2:R50").Copy
w3.Worksheets("kanlar").Range("A2").PasteSpecial Paste:=xlPasteFormulas
 
w2.Worksheets("doz").Range("A2:D40").Copy
w3.Worksheets("doz").Range("A2").PasteSpecial Paste:=xlPasteValues
 
w2.Worksheets("Tutulum Paterni").Range("A2:D50").Copy
w3.Worksheets("Tutulum Paterni").Range("A2").PasteSpecial Paste:=xlPasteValues
 
w2.Worksheets("Dozimetri").Range("A2:C50").Copy
w3.Worksheets("Dozimetri").Range("A2").PasteSpecial Paste:=xlPasteValues
 
w2.Worksheets("Konsey_ekibi").Range("A2:I100").Copy
w3.Worksheets("Konsey_ekibi").Range("A2").PasteSpecial Paste:=xlPasteValues

'KİMLİK SAYFASI BURADAN BAŞLIYOR.

k2.Range("C1").Copy
k3.Range("C1").PasteSpecial Paste:=xlPasteValues
 
k2.Range("C2").Copy
k3.Range("C2").PasteSpecial Paste:=xlPasteValues
 
k2.Range("C3").Copy
k3.Range("C3").PasteSpecial Paste:=xlPasteValues
 
k2.Range("C5").Copy
k3.Range("C5").PasteSpecial Paste:=xlPasteValues
    
k2.Range("H1").Copy
k3.Range("H1").PasteSpecial Paste:=xlPasteValues
 
k2.Range("H2").Copy
k3.Range("H2").PasteSpecial Paste:=xlPasteValues
 
k2.Range("H3").Copy
k3.Range("H3").PasteSpecial Paste:=xlPasteValues
 
'TANISI
k2.Range("C9").Copy
k3.Range("C9").PasteSpecial Paste:=xlPasteValues
    
'EX TARİHİ
k2.Range("I5").Copy
k3.Range("I5").PasteSpecial Paste:=xlPasteValues
 
'HİKAYE
k2.Range("B19:B23").Copy
k3.Range("B19:B23").PasteSpecial Paste:=xlPasteValues
 
k2.Range("B28:B32").Copy
k3.Range("B28:B32").PasteSpecial Paste:=xlPasteValues
 
k2.Range("D19:D23").Copy
k3.Range("D19:D23").PasteSpecial Paste:=xlPasteValues
 
k2.Range("D28:D32").Copy
k3.Range("D28:D32").PasteSpecial Paste:=xlPasteValues
 
'PATOLOJİ
k2.Range("A39").Copy
k3.Range("A39").PasteSpecial Paste:=xlPasteValues

'ÖYKÜ
w3.Worksheets("kimlik").oyku.Value = w2.Worksheets("kimlik").oyku.Value
 
Application.CutCopyMode = False

w2.Close 0
Kill fname
w3.Worksheets("Formlar").Select
w3.SaveAs Filename:=fname
w3.Close 0

Next i

End Sub

Önerileriniz için teşekkürler

 

[mrwarrior]

Ben uygulamalarımda islemleri iptal edip sonra normal e çeviriyorum. Bayağı hızlanıyor.

Sub islemiptal()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
End Sub


Sub islemnormal()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Korhan Ayhan]

Birkaç örnek dosya ekleyip yapmak istediğiniz işlemi açıklarsanız daha hızlı yöntemler önerilebilir.

 

[seckinb]

Ben uygulamalarımda islemleri iptal edip sonra normal e çeviriyorum. Bayağı hızlanıyor.

Sub islemiptal()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
End Sub


Sub islemnormal()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

kullandığım kodun hızını en az %100 arttırdı.
teşekkürler.