A Sütunundaki Adresten Dosya Taşıma

[askm]

Hayırlı akşamlar.
A sütununda hücre adresleri, B sutununda dosya isimleri mevcut. B sutununda isimleri mevcut bu dosyaları a sütunundaki adreslerden alıp D sürücüsüne aşınan adında klasör yok ise yeni klasör açarak, klasör var ise direkt taşıma imkanı var mıdır.
Teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

A sütununda hücre adresleri aşağıdaki gibi olmalıdır.

"C:\Deneme"

Eğer adres sonunda "\" varsa kod içindeki kırmızı bölümü siliniz.

Sub Dosyalari_Tasi()
    Dim Kontrol As String, X As Long
    Dim Kaynak_Klasor As String, Say As Long
    Dim Hedef_Klasor As String, Dosya As String
   
    Hedef_Klasor = "D:\Taşınan\"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    If FSO.FolderExists(Hedef_Klasor) = False Then
        MkDir Hedef_Klasor
    End If
   
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        Kaynak_Klasor = Cells(X, 1) & "\"
        Dosya = Cells(X, 2)
        Kontrol = Dir(Kaynak_Klasor & Dosya)
       
        If Kontrol <> "" Then
            FileCopy Kaynak_Klasor & Dosya, Hedef_Klasor & Dosya
            Say = Say + 1
            Kill Kaynak_Klasor & Dosya
        End If
    Next
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
            Say & " adet dosya taşınmıştır.", vbInformation
End Sub