vba kodu ile uzak bilgisayardaki dosyaları kopyalama

[yyhy]

vba kodu ile uzak bilgisayardaki dosyaları kopyalamak istiyorum. Forumdaki örnekleri inceledim. Ama bir türlü yapamadım.
Uzak bilgisayar örnek verecek olursam;
\\192.168.42.175\Koordine\Görevliler\Kaynak\ içerisinde 48 adet klasör var ve klasörler içerisinde o birime ait *.xlsx dosyaları mevcut. ( Ben örnekte Birim (1).........Birim (48) adlandırdım ama isimler farklı) Klasörlerin hepsine ayrı ayrı girip kopyalama zaman almakta ben bu xlsx dosyalarını hedef klasöre nasıl aldırabilirim?
Acaba bir vba kod hazırlanabilse koda çitf tıklayınca benim bilgisayarımdaki D:\Belgelerim\Haftalık\ içerisine getirmek istiyorum.
Yardımcı olabilecek arkadaşlara teşekkür ederim.

 

[Korhan Ayhan]

Deneyiniz.

Kod içinde ki YOL tanımı bölümüne uzak bilgisayarın yolunu yazınız.

Option Explicit

Dim Dosya_Sistemi As Object, Yol As String, Hedef_Klasor As String
Dim Dosya As Object, Alt_Klasorler As Object, Say As Long, Onay As Byte, Zaman As Double
  
Sub Klasor_Secimi()
    Yol = "\\192.168.42.175\Koordine\Görevliler\Kaynak\"
  
    Onay = MsgBox("Seçtiğiniz klasör ve alt klasörlerindeki tüm excel dosyaları kopyalanacaktır!" & vbCr & vbCr & _
                  "İşlemi onaylıyor musunuz?" & vbCr & vbCr & Yol, vbCritical + vbYesNo + vbDefaultButton2)
  
    If Onay = vbNo Then Exit Sub
  
    If Dir(Yol, vbDirectory) <> "" Then
        Zaman = Timer
      
        Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
      
        Say = 0
          
        Hedef_Klasor = "D:\Belgelerim\Haftalık\"
      
        If Dir(Hedef_Klasor, vbDirectory) = "" Then MkDir Hedef_Klasor
      
        Call Dosyalari_Kopyala(Yol, True)
  
        MsgBox Say & " adet dosya kopyalanamıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Kaynak klasör bulunamadı!" & vbCr & vbCr & Yol, vbExclamation
    End If
End Sub

Sub Dosyalari_Kopyala(Klasor As String, Alt_Klasorler_Dahilmi As Boolean)
    For Each Dosya In Dosya_Sistemi.GetFolder(Klasor).Files
        If Dosya_Sistemi.GetExtensionName(Dosya) = "xlsx" Then
            Say = Say + 1
            Dosya_Sistemi.Copyfile Dosya, Hedef_Klasor & Dosya.Name
        End If
    Next
  
    If Alt_Klasorler_Dahilmi Then
        For Each Alt_Klasorler In Dosya_Sistemi.GetFolder(Klasor).SubFolders
            Call Dosyalari_Kopyala(Alt_Klasorler.Path, True)
        Next
    End If
End Sub

 

[Endless033]

en kısa zamanda deneyeceğim ilden ile mi ,ülkeden ülkeye mi oluyor mu bu formül sadece belli bir modemdeki ağa katılanlar için mi geçerli?

 

[yyhy]

Sayın Korhan Ayhan deneyip bilgi vereceğim.

 

[yyhy]

Sayın Korhan Ayhan verdiğiniz kodu çalışma kitabı kod bölümüne mi yapıştırıp denemem gerekir.
Evde ağ olmadığı için Kaynak klasörünü D:\Kaynak olarak Hedef Klasörünü de D:\Belgelerim}\Haftalık olarak adlandırdım.
Run-time error "52"
Bad file name or number hatası alıyorum. Acaba neyi yanlış yapıyorum.


Option Explicit

Dim Dosya_Sistemi As Object, Yol As String, Hedef_Klasor As String
Dim Dosya As Object, Alt_Klasorler As Object, Say As Long, Onay As Byte, Zaman As Double

Sub Klasor_Secimi()
Yol = "D:\Kaynak\"

Onay = MsgBox("Seçtiğiniz klasör ve alt klasörlerindeki tüm excel dosyaları kopyalanacaktır!" & vbCr & vbCr & _
"İşlemi onaylıyor musunuz?" & vbCr & vbCr & Yol, vbCritical + vbYesNo + vbDefaultButton2)

If Onay = vbNo Then Exit Sub

If Dir(Yol, vbDirectory) <> "" Then
Zaman = Timer

Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")

Say = 0

Hedef_Klasor = "D:\Belgelerim\Haftalık\"

If Dir(Hedef_Klasor, vbDirectory) = "" Then MkDir Hedef_Klasor

Call Dosyalari_Kopyala(Yol, True)

MsgBox Say & " adet dosya kopyalanamıştır." & vbCr & vbCr & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
Else
MsgBox "Kaynak klasör bulunamadı!" & vbCr & vbCr & Yol, vbExclamation
End If
End Sub

Sub Dosyalari_Kopyala(Klasor As String, Alt_Klasorler_Dahilmi As Boolean)
For Each Dosya In Dosya_Sistemi.GetFolder(Klasor).Files
If Dosya_Sistemi.GetExtensionName(Dosya) = "xlsx" Then
Say = Say + 1
Dosya_Sistemi.Copyfile Dosya, Hedef_Klasor & Dosya
End If
Next

If Alt_Klasorler_Dahilmi Then
For Each Alt_Klasorler In Dosya_Sistemi.GetFolder(Klasor).SubFolders
Call Dosyalari_Kopyala(Alt_Klasorler.Path, True)
Next
End If
End Sub

 

[Korhan Ayhan]

Kodun son halini deneyiniz.

 

[usubaykan]

@Korhan Ayhan ellerinize emeğinize sağlık.
@yyhy
Bende de hata verdi hata veren kodu bu şekilde değiştirip tekrar deneyiniz.

   Dosya_Sistemi.Copyfile Dosya, Hedef_Klasor '& Dosya

 

[yyhy]

Sayın @Korhan Ayhan ve @usubaykan verilen bilgiler ışığında kodu tekrar deneyip bilgi vereceğim.

 

[yyhy]

Sayın @Korhan Ayhan ve @usubaykan 2. mesajda verilen kod çok güzel bir şekilde çalıştı ve ihtiyaca cevap verdi. Çok teşekkür ederim. Elinize sağlık.

 

[yyhy]

@Korhan Ayhan @usubaykan teşekkür ederim ellerinize emeğinize sağlık.