belirttiğim klasörün içindeki tüm dosyalara formül uygulatma

[desk]

Örnek klasörünün içinde ve içindeki klasörlerin içinde bulunan dosyalardaki j13 den j1000 e kadar formül yerleştirmek istiyorum. örnek dosyam ektedir çok fazla excel dosyası olduğundan çok uzun zamanı mı alacak böyle birsey yapmak mümkünmü şimdiden tşkler.

 

[desk]

Arkadaşlar yardım edebilirmisiniz.

 

[desk]

Böyle birsey mümkün değilmi?

 

[desk]

Çok önemliydi bir yardım çok fazla önemli.!

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Kodu çalıştırdığınızda Klasör seçme penceresi gelecektir. Buradan seçeceğiniz klasör ve alt klasörlerdeki tüm excel dosyalarınızın "J13:J1000" hücre aralığına "=J12+H13-I13" formülü uygulanacaktır.

Option Explicit
 
Sub Klasördeki_Dosyalara_Formül_Uygula()
    Dim Klasör As Object
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    [A2:B65536].ClearContents
    Liste (Klasör.Items.Item.Path)
    Alt_Liste (Klasör.Items.Item.Path)
    Set Klasör = Nothing
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Private Sub Liste(Yol As String)
    Dim Dosya As String, Hedef_Dosya As Workbook
    On Error Resume Next
    Dosya = Dir(Yol & "\*.xls")
    
    While Dosya <> ""
        Application.ScreenUpdating = False
        DoEvents
        Set Hedef_Dosya = Workbooks.Open(Yol & "\" & Dosya, False, False)
        Range("J13:J1000").Formula = "=J12+H13-I13"
        Hedef_Dosya.Close True
        Dosya = Dir
        Application.ScreenUpdating = True
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Dim Alt_Klasör As Object, Alt_Dosya As Object, Dosya As String, Hedef_Dosya As Workbook
    Set Alt_Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasör
    Dosya = Dir(Alt_Dosya.Path & "\*.xls")
        While Dosya <> ""
            Application.ScreenUpdating = False
            DoEvents
            Set Hedef_Dosya = Workbooks.Open(Alt_Dosya & "\" & Dosya, False, False)
            Range("J13:J1000").Formula = "=J12+H13-I13"
            Hedef_Dosya.Close True
            Dosya = Dir
            Application.ScreenUpdating = True
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Alt_Klasör = Nothing
End Sub

 

[parametre]

ilginç bir yaklasım kurnazca bşraz