Formullü hücreleri makro ile son veriye kadar genişletmek

[hopeful]

Merhabalar,
Şimdilik A2:F2118 aralığında veriler bulunmakta.
G2:H2118 aralığına (Veri girdikçe de G2:H.... aralığında) hücrelerin formüllü olarak yapıştırılmasını, ardından sadece değerlerinin yapıştırılmasını istiyorum.

Bu amaçla aşağıdaki gibi bir makro hazırladım:
(G1048571ve H1048571 e formulleri yazdım. buradan ilgili yerlere formülleri kopyalama ve değerleri yapıştırna yaptırıyorum)
Ancak ana dosyamda başka veriler olmasından kaynaklı mı bilmiyorum çok ağır çalışıyor.

Sub veri_guncelle()
Selection.End(xlDown).Select
Range("G1048571:H1048571").Select
Selection.Copy
Range("F1048571").Select
Selection.End(xlUp).Select
ActiveWindow.SmallScroll Down:=-9
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

End Sub


Ağır çalışmasını engellemek adına yeni bir makro önerir misiniz.
Yardımlarınızı rica ederim,

saygılarımla,

 

[Korhan Ayhan]

Merhaba,

Kullandığınız formül nedir?

Ek olarak dosyanızın boyutu nedir?

 

[hopeful]

Ana dosya 25 Mb civarı..

İki hücredeki formülüm aşağıdaki gibi:

G1048571 =IFERROR(SEARCH(";";D1048571;1);"-")
H1048571 =IF(G1048571<>"-";B1048571&": "&LEFT(D1048571;G1048571-1)&" "&C1048571;B1048571&": "&D1048571&" "&C1048571)

 

[Korhan Ayhan]

Dosyanızın boyutu büyük görünüyor. Bu sebeple yavaş çalışıyordur.

Kodlarınızı aşağıdaki gibi kısaltabilirsiniz.

Sub Veri_Guncelle()
    Application.ScreenUpdating = 0
    Application.Calculation = 0
    Range("G1048571:H1048571").Copy
    Satir = Cells(Rows.Count, "F").End(3).Row
    Son = Cells(Satir, "H").End(4).Row
    Range(Cells(Satir, "G"), Cells(Son, "H")).PasteSpecial xlPasteFormulas
    Range(Cells(Satir, "G"), Cells(Son, "H")).Copy
    Range(Cells(Satir, "G"), Cells(Son, "H")).PasteSpecial xlPasteValues
    Range("G1").Select
    Application.CutCopyMode = 0
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub

 

[hopeful]

Sayın Korhan,
Makro formülleri dikkate almadan, sadece değerleri yapıştırdı.

Küçük bir talep daha ilave ederek dosyayı ekledim.

incelemenizi rica ederim,
Saygılarımla