Kod yapılandırma

[selocanexcel]

Merhaba;
Aşağıdaki gibi bir kodlamayla verileri belirtilen tabloya getirebiliyorum fakat bu işlem sırasında sürekli sayfa geçişi olduğu için hissedilir bir duraksama ve ekranda titreme oluyor. kod kısaltılarak veya farklı bir yöntemle bu işlem daha hızlı ve kesintisiz yapılabilirmi.
Örneğin : tek seferde belirtilen hücreler kopyalansın, tek seferde hedef hücrelere yapıştırılsın.

teşekkürler.


mevcut kod

Sheets("sabit").Visible = True
Set s1 = Sheets("FR.01 Ek A Planlama")
Set s2 = Sheets("sabit")
Set s3 = Sheets("2018")

ActiveCell.EntireRow.Copy
Sheets("2018").Select
Range("A70").Select
ActiveSheet.Paste
Application.CutCopyMode = False
If s2.Range("O70") = "AŞAMA 1" Then
s1.Range("B14").Value = s2.Range("C70").Value
s1.Range("B19").Value = s2.Range("E70").Value
s1.Range("D2").Value = s2.Range("F70").Value
s1.Range("B3").Value = s2.Range("G70").Value
s1.Range("B4").Value = s2.Range("H70").Value
s1.Range("D4").Value = s2.Range("I70").Value
s1.Range("B5").Value = s2.Range("J70").Value
s1.Range("B12").Value = s2.Range("K70").Value
s1.Range("B11").Value = s2.Range("L70").Value
s1.Range("B10").Value = s2.Range("M70").Value
s1.Range("D6").Value = s2.Range("N70").Value
s1.Range("D15").Value = s2.Range("O70").Value
s1.Range("D14").Value = s2.Range("P70").Value
s1.Range("D13").Value = s2.Range("Q70").Value
s1.Range("B20").Value = s2.Range("R70").Value
s1.Range("B24").Value = s2.Range("S70").Value
s1.Range("D18").Value = s2.Range("T70").Value
s1.Range("B22").Value = s2.Range("U70").Value
s1.Range("B26").Value = s2.Range("V70").Value
s1.Range("B23").Value = s2.Range("W70").Value
s1.Range("B27").Value = s2.Range("X70").Value
s1.Range("B28").Value = s2.Range("Y70").Value
s1.Range("B29").Value = s2.Range("Z70").Value
s1.Range("B30").Value = s2.Range("AA70").Value
s1.Range("B31").Value = s2.Range("AB70").Value
s1.Range("B32").Value = s2.Range("AC70").Value
s1.Range("B33").Value = s2.Range("AD70").Value
s1.Range("B34").Value = s2.Range("AE70").Value
s1.Range("B35").Value = s2.Range("AF70").Value
s1.Range("B36").Value = s2.Range("AG70").Value
s1.Range("B37").Value = s2.Range("AH70").Value
s1.Range("B38").Value = s2.Range("AI70").Value
s1.Range("B39").Value = s2.Range("AJ70").Value
s1.Range("B40").Value = s2.Range("AK70").Value
s1.Range("B41").Value = s2.Range("AL70").Value
s1.Range("B42").Value = s2.Range("AM70").Value
s1.Range("B2").Value = s2.Range("AN70").Value
s1.Range("B7").Value = s2.Range("AO70").Value
s1.Range("B8").Value = s2.Range("AP70").Value
s1.Range("B9").Value = s2.Range("AQ70").Value
s1.Range("B13").Value = s2.Range("AR70").Value
s1.Range("D7").Value = s2.Range("AS70").Value
s1.Range("D8").Value = s2.Range("AT70").Value
s1.Range("D9").Value = s2.Range("AU70").Value
s1.Range("D10").Value = s2.Range("AV70").Value
s1.Range("D11").Value = s2.Range("AW70").Value
s1.Range("D12").Value = s2.Range("AX70").Value
s1.Range("D17").Value = s2.Range("AY70").Value
s1.Range("D19").Value = s2.Range("AZ70").Value
s1.Range("D20").Value = s2.Range("BA70").Value
s1.Range("B25").Value = s2.Range("BB70").Value
s1.Range("B15").Value = s2.Range("BC70").Value
s1.Range("B16").Value = s2.Range("BD70").Value
s1.Range("B17").Value = s2.Range("BE70").Value
s1.Range("B18").Value = s2.Range("BF70").Value

Sheets("sabit").Select
ActiveWindow.SelectedSheets.Visible = False
Application.CutCopyMode = False
End If
end sub

 

[numan şamil]

Merhaba
Kodlarına

Set s3 = Sheets("2018") ' den sora
[COLOR="Red"]Application.ScreenUpdating = False[/COLOR]
Ve En son End Sub  dan önce

[COLOR="Red"]Application.ScreenUpdating = True[/COLOR]
Ekleyip denermisiniz