bir klasör içindeki tüm excel dosyalarına veri yazdırma

[sunkid]

Merhaba arkadaşlar, yaklaşık 1.500 'e yakın excel dosyam var hepsi aynı klasör içinde. a1 ve b1 hücrelerine otomatik olarak ortak bir yazı yazdırmak istiyorum. a1 hücresine ocak 2013 b1 hücresine 1.200 yazmasını istiyorum. 1.500 excel sayfasına girip aynı işlemi yapmak oldukça zaman alacak bunun otomatik olarak bir makro ile sağlanması mümkün mü? yardımlarınız için şimdiden teşekkürler..

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodları deneyiniz.

Kodu çalıştırdığınızda sizden bir klasör seçmenizi ister. Seçtiğiniz klasör ve alt klasörlerdeki tüm excel dosyalarınızın ilk sayfasındaki belirttiğiniz hücrelerine belirttiğiniz verileri yazar. 1500 dosya için işlem biraz uzun sürebilir. İlgili dosyalarda birden fazla sayfa varsa ve tümüne bu bilgileri yazmak isterseniz koda ekleme yapmak gerekecektir.

Sub Klasördeki_Dosyalara_Veri_Yaz()
    Dim Klasör As Object
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    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("A1") = "Ocak 2013"
        Range("B1") = 1200
        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("A1") = "Ocak 2013"
            Range("B1") = 1200
            Hedef_Dosya.Close True
            Dosya = Dir
            Application.ScreenUpdating = True
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Alt_Klasör = Nothing
End Sub

 

[sunkid]

Korhan hocam, Allah razı olsun beni büyük bir meşakatten kurtardınız. Sayın hocam soruyu açarken aslında eksik ifade ettim kusura bakmayın. Şöyle bir şey yapmamız mümkün olur mu? Öncelikle excel dosyalarım hakkında size bilgi vereyim. Klasör içinde bulunan excel dosyalarımın hepsi tek tip halinde ve hepsi 6 sheet ten oluşturulmuştur. Esasen şunu istiyorum yazdıracağım veri 4. sheet te A20 ile B20 hücreleridir geneli bu şekildedir.. Ama bazı dosyalarda hücre numaraları farklılık gösterebiliyor. Yazılacak veri A19 ile B19 da olabilir veya A22 ile B22 de olabilir. makronun hangi hücreye veriyi yazacağını ayırt edebilmesi için bir kriter mevcut aslında. Şöyle ki A kolonunda şuan hali hazırdaki en son hücrede Aralık 2012 yazıyor. (dosyasına göre değişiyor A19 - A20 - A21). Şöyle bir makro yazılabilir mi? A kolonuna bak Aralık 2012 yazan hücrenin bulduğu bir alt hücreye Ocak 2013 hemen yanındaki B kolonun karşısına 1.200 yaz. Hocam çok mu fantastik oldu bilmiyorum ama bana bunu sağlayacak kodu yazabilmeniz iş hayatındaki istikbalimi olumlu yönde etkileyecektir. Şimdiden çok çok teşekkür ediyorum değerli yardımlarınız için.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub Klasördeki_Dosyalara_Veri_Yaz()
    Dim Klasör As Object
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    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, Satir As Long

    On Error Resume Next
    Dosya = Dir(Yol & "\*.xls")
    
    While Dosya <> ""
        Application.ScreenUpdating = False
        DoEvents
        Set Hedef_Dosya = Workbooks.Open(Yol & "\" & Dosya, False, False)
        With Sheets(4)
            Satir = .Cells(Rows.Count, 1).End(3).Row + 1
            .Cells(Satir, 1) = "Ocak 2013"
            .Cells(Satir, 2) = 1200
        End With
        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, Satir As Long
    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)
            With Sheets(4)
                Satir = .Cells(Rows.Count, 1).End(3).Row + 1
                .Cells(Satir, 1) = "Ocak 2013"
                .Cells(Satir, 2) = 1200
            End With
            Hedef_Dosya.Close True
            Dosya = Dir
            Application.ScreenUpdating = True
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Alt_Klasör = Nothing
End Sub

 

[sunkid]

hocam excel de mangal yakılacak marko yaza bilirmisin? üstad eline sağlık verdiğin makro işime yaradı teşekkür ederim..