klasör icindeki klasörlere örnek bir excel dosyasını kopyalama.

[Rainbows]

Merhaba arkadaşlar,

örnegin c:\test klasörünün icindeki klasörlere test.xlsm isimli excel dosyasını, a1 hücresinde yazan yazıyı örnegin: "mart-2017" test exceline isim vererek kopyalamak istiyorum.

kısaca test klasörünün icindeki örnegin 5 tane klasöre (bu sayı degişebilirde)mart-2017 ismiyle test.xlsm klasörünü kopyalamak istiyorum.

altın üyeligim sona erdigi icin örnek dosya ekleyemiyorum.

yardımlarınız için şimdiden teşekkürler.

 

[vardar07]

Dosya upload sitesine yükleyip link verebilirsiniz.

 

[Rainbows]

Dosya upload sitesine yükleyip link verebilirsiniz.

örnek dosyayı yükledim.

http://www.dosyaupload.com/4Ed8

 

[Rainbows]

Arkadaşlar bu konuda yardımcı olabilecek birisi yokmudur

 

[PLİNT]

Merhaba
Aşağıdaki gibi denermisiniz?
Ana dosyanın yanında bulunan "test.xlsm"; "C:\test" klasörü içindeki alt klasörlere kopyanacak ve adı değişecek.

[SIZE="2"]Sub kopyala()
Dim ds, f
If [B1] = "" Then Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("c:\test")
For Each klas In f.subfolders
ds.CopyFile ThisWorkbook.Path & "\test.xlsm", klas & "\"
Name klas & "\" & "test.xlsm" As klas & "\" & [B1].Value & ".xlsm"
Next
End Sub[/SIZE]

 

[Rainbows]

cok teşekkürler cok güzel olmuş ellerize saglık. sadece kücük bir sıkıntı var. aynı isimde excel dosyası oldugu zaman hata veriyor. bunu nasıl kontrol edebiliriz.

 

[PLİNT]

aynı isimde excel dosyası oldugu zaman hata veriyor. bunu nasıl kontrol edebiliriz.

Merhaba
Aşağıdaki gibi değiştirelim, eğer uyarı vermesin derseniz kırmızı bölümü silersiniz.

 [SIZE="2"]Sub kopyala()
Dim ds, f
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("c:\test")
For Each klas In f.subfolders
If ds.FileExists(klas & "\" & [B1].Value & ".xlsm") = False Then
If ds.FileExists(klas & "\[COLOR="Blue"]test[/COLOR].xlsm") = True Then Kill klas & "\[COLOR="Blue"]test[/COLOR].xlsm"
ds.CopyFile ThisWorkbook.Path & "\[COLOR="Blue"]test[/COLOR].xlsm", klas & "\"
Name klas & "\" & "[COLOR="Blue"]test[/COLOR].xlsm" As klas & "\" & [B1].Value & ".xlsm"
[COLOR="Red"]Else
MsgBox klas & " Klasöründe " & [B1].Value & ".xlsm" & vbCrLf & _
" adlı dosya zaten var"[/COLOR]
End If
Next
End Sub [/SIZE]

 

[Rainbows]

Çok teşekkürler tam istedigim gibi oldu.