Makro ile formül yazdırma

[muratsaraldi]

Merhaba,

Aşağıdaki makro ile bir klasördeki birden çok excel dosyasından veri çekiyorum.Ancak klasördeki dosyaları güncellediğimde tekrar makroyu çalıştırıp 1000 tane dosyayı tekrar makro ile güncellemem gerekiyor ve çok zaman alıyor.
Yapmak istediğim makro eğer düşeyara formülünü hücreye eklerse dosyayı değiştiğimde kendiliğinden güncellenir.

Yardımlarınız için teşekkürler.

Sub kapaliDosyalardanVeriAl()
    Dim con As Object
    Dim rs As Object
    Set actSheet = ActiveSheet

    sorgu = "select * from [Sayfa1$I1:T42]"

    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")

    'klasor = "d:\"
    klasor = "\\server\F\KALIPHANE\Kalip Maliyetleri\Kaliplar\"

    ADRES = ("A10,B2,N3,D8,I6,J6,K6,P7,Q7,R7," & _
             "I8,J8,K8,P9,Q9,R9,I10,J10,K10,P11,Q11,R11,I12,J12," & _
             "K12,P13,Q13,R13,I14,J14,K14,P15,Q15,R15,I16,J16,K16," & _
             "P17,Q17,R17,I18,J18,K18,P19,Q19,R19,I20,J20,K20,P21,Q21," & _
             "R21,I22,J22,K22,P23,Q23,R23,I24,J24,K24,P25,Q25,R25,I26," & _
             "J26,K26,P27,Q27,R27,I28,J28,K28,P29,Q29,R29,I30,J30,K30," & _
             "P31,Q31,R31,I32,J32,K32,P33,Q33,R33,I34,J34,K34,P35,Q35," & _
             "R35,I36,J36,K36,P37,Q37,R37,I38,J38,K38,P39,Q39,R39,I40,J40," & _
             "K40,P41,P41,Q41,Q41,R41,R41,I42,J42,K42")

    adresler = Split(ADRES, ",")
    sat = Cells(Rows.Count, "A").End(3).Row + 1

    Set tmpSheet = Sheets.Add
    actSheet.Select
    tmpSheet.Visible = False
    For Each dosyaname In CreateObject("Scripting.FileSystemObject").GetFolder(klasor).Files
        If ThisWorkbook.Name = dosyaname Or Right(dosyaname, 3) <> "xls" Then GoTo atla:

        con.Open "provider=microsoft.jet.oledb.4.0;data source=" & dosyaname & _
                 ";extended properties=""excel 8.0;hdr=yes"""

        rs.Open sorgu, con, 1, 1

        tmpSheet.Cells.ClearContents
        tmpSheet.Range("I2").Cells.CopyFromRecordset rs
        con.Close

        'verileri aktarma kısmı ********
        For sut = 1 To 118
            Cells(sat, sut) = tmpSheet.Range(adresler(sut - 1))
        Next sut
        '*******************************
        sat = sat + 1

atla:

    Next dosyaname

    MsgBox "BİTİİ"

    Application.DisplayAlerts = False
    tmpSheet.Delete
    Application.DisplayAlerts = True
    
    Erase adresler
    Set tmpSheet = Nothing
    Set actSheet = Nothing
    Set rs = Nothing
    Set con = Nothing
End Sub