Klasördeki excel dosyalarını Farklı bir klasör altında toplamak

[kulge]

Arkadaşlar Merhaba..

Benim şöyle bi sorunum var hazırladıgım excel toplasundaki a1,a2,a3 hücrelerindeki isimlere istinaden c:\yeni klasör\ içerisindeki aynı isimli .xls dosyalarını belirtigimiz bir klasör altına kopyalamasını istiyorum hatta ve hatta bu dosyaların ziplenip belirtigimiz mail adresine gönderilmesini istiyom...Bu konuda bana yardımlarını esirgemeyen arkadaşlara şimdiden teşekür ederim...

 

[kulge]

Arkadaşlar herhalde ben tam olarak sorunumu anlatamadım kimse cevap vermedi...Şu şekilde bir defa daha açıklamaya çalışayım üstatlar küçük bir makro ile çözeceklerine eminim;Bana günde bin adet excell dosyası geliyor bunların icerisinden ise bana sadece günlük değişmek kaydı ile 100 ile 150 arasında excell dosyası lazım oluyor.Bana gelen bin adet excell dosyasından ben günlük lazım olan dosyaları inceleyip mail gönderiyorum yanlız incelemek için önce bana lazım olan bu yüz dosyayı bir ayırmam gerekiyor bunları gelen dosyadan ayırmak için,günlük listede zaten elimde oldugundan excelldeki bu listemi gelen dosya içerisinden küçük bir makro yardımı ile başka bir klasöre kopyalamak istiyorum ondan sonrası zaten kolay ama her gün bin dosya içerisinden benden istenen dosyaları ayırmak bile zaman alıyor.Ben bunları yardımınızla ugraşmadan ayırmak istiyorum..Yardımlarınınz için Teşekür ederim...

 

[hamitcan]

Sub dosyakopyala()
    Set ds = CreateObject("Scripting.FileSystemObject")
    son = [a65536].End(3).Row
    kaynak = InputBox("Kaynak Dosyaların Bulunduğu Klasörü Girin", , "c:\yeni klasör\")
    hedef = InputBox("Hedef Dosyaların Bulunduğu Klasörü Girin", , "c:\yeni klasör2\")
    For i = 2 To son
        dosya = Cells(i, 1)
        a = ds.fileExists(hedef & dosya)
        If a = True Then MsgBox dosya & " İsminde Dosya Mevcut": Exit Sub
        f = ds.copyFile(dosya, hedef)
    Next
End Sub

Not:Kod biraz daha geliştirilebilir.Ayrıca dosya isimlerini uzantısı ile birlikte girmeyi unutmayın.