Klasörler içerisine word ve excel çalışma dosyaları ekleme

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim ANA VERİ klasör içerisindeki KLASÖRLERE DAĞIT excel dosyamın B2 hücresinden aşağıya doğru isimleri yazılı dosyaları ANA VERİ klasör içerisindeki klasörlere dağıtmak istiyorum.

Yardım eder misiniz?

 

[Korhan Ayhan]

Deneyin.

Option Explicit

Sub DOSYALARI_KLASÖRLERE_DAĞIT()
    Dim Yol As String, FSO As Object, Ana_Klasör_Yolu As Object, Alt_Klasör_Yolu As Object
    Dim Son As Long, Klasör As Object, Veri As Range, Dosya_Adi As String
    
    Yol = ThisWorkbook.Path
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Ana_Klasör_Yolu = FSO.GetFolder(Yol)
    Set Alt_Klasör_Yolu = Ana_Klasör_Yolu.SubFolders
    
    Son = Cells(Rows.Count, 2).End(3).Row
    
    For Each Klasör In Alt_Klasör_Yolu
        For Each Veri In Range("B2:B" & Son)
            Dosya_Adi = Dir(Yol & "\" & Veri.Value & ".*")
            If Dosya_Adi <> "" Then
                FSO.CopyFile Yol & "\" & Dosya_Adi, Klasör & "\" & Dosya_Adi
            End If
        Next
    Next
    
    Set FSO = Nothing
    Set Ana_Klasör_Yolu = Nothing
    Set Alt_Klasör_Yolu = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ASLAN7410]

Sayın Korhan Bey ellerinize sağlık tam istediğim gibi oldu, çok teşekkür ediyorum, Allah razı olsun.

Hayırlı geceler hayırlı çalışmalar.