vba kodu ile uzak bilgisayardaki dosyaları kopyalama

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
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.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

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

C++:
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

Altın Üye
Katılım
25 Haziran 2013
Mesajlar
140
Excel Vers. ve Dili
türkçe
Altın Üyelik Bitiş Tarihi
07-09-2025
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

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
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
 

Ekli dosyalar

Son düzenleme:

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodun son halini deneyiniz.
 

usubaykan

Destek Ekibi
Destek Ekibi
Katılım
16 Mayıs 2008
Mesajlar
561
Excel Vers. ve Dili
Ev : Office Excel 2003
İş : Office Excel 2003
@Korhan Ayhan ellerinize emeğinize sağlık.
@yyhy
Bende de hata verdi hata veren kodu bu şekilde değiştirip tekrar deneyiniz.
Kod:
   Dosya_Sistemi.Copyfile Dosya, Hedef_Klasor '& Dosya
 

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
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

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
@Korhan Ayhan @usubaykan teşekkür ederim ellerinize emeğinize sağlık.
 
Üst