Çözüldü Klasör kopyalama macrosu

[Paşa3535]

Merhabalar,
Bir klasör içindeki klasörleri başka bir klasör içine kopylamak istiyorum. Örneğin A sütununda yazmış olduğum listedeki klasörler b sütunundaki hedef klasörlerin içine kopyalansın.Klasör içindeki dosyaları değil direkt klasörleri kopylamak istiyorum.

Teşekkürler

 

[Erkan Akayay]

Affedersiniz ama neden klasör kopyalamak için Excel kullanıyorsunuz?

 

[Paşa3535]

Çünkü 268 adet alt klasör var ve bunları 42 adet ana klasörlerin içine kopyalamam gerekiyor ve bu macroya sürekli olarak ihtiyacım olacak.

Örnek :

Alt Klasör adı Hedef Klasör Adı ABA1 PAKET1 AACA2 PAKET1 BBA1 PAKET3 CAB5 PAKET4

 

[Erkan Akayay]

Klasör kopyalama kodu aşağıdaki gibi.

Sub KlasorKopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    
    Kaynak = "C:\kaynak_klasor_yolu\" ' Kopyalanacak klasör.
    Hedef = "c:\hedef_klasor_yolu\" ' Kopyalanacak yer.
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak, Hedef, True
    
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

Siz Exceldeki tanımladığınız yerlere göre yapmak istiyorsanız bir döngü ile yapabilirsiniz. Ama klasör yolları tam girilmeli.

Sub Klasor_Kopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    
    For i = 2 To Range("A" & Rows.Count).End(3).Row
    Kaynak = Cells(i, 1).Value
    'Kaynak="C:\KlasorAdı\"& Cells(i, 1).Value şeklinde koddada klasörü tamamlayabilirsiniz.
    Hedef = Cells(i, 2).Value
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak, Hedef, True
    
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

 

[Paşa3535]

Hocam anlıyamadım kusura bakmayın

 

[Paşa3535]

Sub Copy_PDF_File()

    Dim Rng As Range, My_File As String
    Dim Source_File_Path As String
    Dim File_Count As Long
    
    Source_File_Path = "C:\Users\PASA KARADAG\Desktop\net\"
    
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If Len(Rng.Value) > 0 And Len(Rng.Offset(, 1).Value) > 0 Then
            My_File = Source_File_Path & Rng.Value & ".pdf"
            If Dir(My_File) <> "" Then
                With VBA.CreateObject("Scripting.FileSystemObject")
                    .CopyFile My_File, Rng.Offset(, 1).Value & Application.PathSeparator
                End With
                File_Count = File_Count + 1
            End If
        End If
    Next

    MsgBox Format(File_Count, "#,##0") & " adet dosya başarıyla kopyalandı!"
End Sub

Korhan hoca bunu pdf dosyaları için yazmıştı ve şuan kullanıyorum bunu pdf değilde sadece klasör için değiştirebilir miyiz ?

 

[Erkan Akayay]

Dosyanızda A ve B sütununda sütununda yazanlar klasör adımı? PDF'ler farklı klasör altındaysa Tam klasör adına gerek var. PDF adını arattırıp klasörü kendi bulsunmu istiyorsunuz?

Yeni bir bilgisayar aldım. Hala program kurulumlarıyla uğraştığım ve yeni klavyeme alışamadığım için geri dönüşler biraz gecikiyor. Bir an kendimi kaybedip ihtiyacımdan fazlasınımı aldım şüphesi ayrı konu

 

[Paşa3535]

Hocam şöyle açıklayayım.Bende 1018 adet pdf vardı.Bunları yukarıdaki kod ile 268 adet klasöre kopyaladım.Şuanda 268 adet klasörü 32 adet klasör içine atmak istiyorum. A sütununa Kaynak klasörümde bulunan 268 adet klasörü yazacağım ve B sütununada 32 adet olan hedef klasörlerimi yazacağım. Böylelikle 268 adet klasörü 32 adet klasörün içine kopyalıyabileceğim.

 

[Erkan Akayay]

Tamam klasörü nasıl yazıyorsunuz.
C:\xxxx\yyyy\ gibimi? Onu anlamak istiyorum.
İstediğiniz kolay ama nasıl yazdığınız önemli. Klasör adını nasıl yazdığınıza göre kod yazacağız.

 

[Paşa3535]

Hayır aşağıda bir örnek paylaşıyorum.

TP-BCLSO-0002-H

 

[Erkan Akayay]

Bunlar tek bir klasörün altındamı?
C:\XXX\TP-BCLSO-0002-H gibi tek bir XXX klasörü altındamı?
Öyleyse o klasörün adını verin. Onu kod eklemek lazım.
Farklı klasörler ise farklı kodlama gerek.

Mesela sizin test için oluşturduğum klasör yolu C:\Users\ERKAN\Desktop\Kaynak
Bunlar içine kaynak1, kaynak2 gibi gibi alt klasötler oluşturup size gönderiğim kodu test etmiştim.

 

[Korhan Ayhan]

Örnek dosya paylaşırsanız kod yazmak isteyenler daha hızlı cevap verecektir.

 

[Paşa3535]

Kaynak klasörü = C:\Users\PASA KARADAG\Desktop\paket
İçinde aşağıdaki gibi alt klasörler var

TP-BCLSO-0002-H
TP-BCLSO-0004-H

 

[Paşa3535]

Örnek dosya paylaşırsanız kod yazmak isteyenler daha hızlı cevap verecektir.

Hocam örnek aşağıdadır.

İndir Ornek

Dosyayı indir Ornek

dosya.co

 

[Erkan Akayay]

Deneyin.

Sub Klasor_Kopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    For i = 2 To Range("A" & Rows.Count).End(3).Row
    Kaynak = "C:\Users\PASA KARADAG\Desktop\paket\" & Cells(i, 1).Value
        Hedef = Cells(i, 2).Value
        Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak, Hedef, True
    Next
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

 

[Paşa3535]

Deneyin.

Sub Klasor_Kopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    For i = 2 To Range("A" & Rows.Count).End(3).Row
    Kaynak = "C:\Users\PASA KARADAG\Desktop\paket\" & Cells(i, 1).Value
        Hedef = Cells(i, 2).Value
        Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak, Hedef, True
    Next
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

Hocam bu klasörün kendisini değil içindekileri kopyaladı . Ben direkt klasörü kopyalasın istiyorum

 

[Erkan Akayay]

Öncekini ezbere yazdım. Ufak bir şey atlamışım. Şimdi deneyerek gönderiyorum.

Sub Klasor_Kopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    For i = 2 To Range("A" & Rows.Count).End(3).Row
    Kaynak = "C:\Users\PASA KARADAG\Desktop\paket\" & Cells(i, 1).Value
        Hedef = Cells(i, 2).Value
        Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak & "*", Hedef, True
    Next
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

 

[Paşa3535]

Öncekini ezbere yazdım. Ufak bir şey atlamışım. Şimdi deneyerek gönderiyorum.

Sub Klasor_Kopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    For i = 2 To Range("A" & Rows.Count).End(3).Row
    Kaynak = "C:\Users\PASA KARADAG\Desktop\paket\" & Cells(i, 1).Value
        Hedef = Cells(i, 2).Value
        Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak & "*", Hedef, True
    Next
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

Çok teşekkür ederim çalışıyor. Kopyalayamadıklarını renklendirebilir miyiz size zahmet

 

[Erkan Akayay]

Ben size kodun en ham halini verdim. Bu kodda kopyalama yapamadığında hata verir. Dosyaya hata kontrolleri eklemek gerekecek.
Şu an biraz yoğunum. Eğer diğer arkadaşlarımız fırsat bulup eklemeleri yapmamışsa müsait olduğumda revize ederim.

 

[Paşa3535]

Ben size kodun en ham halini verdim. Bu kodda kopyalama yapamadığında hata verir. Dosyaya hata kontrolleri eklemek gerekecek.
Şu an biraz yoğunum. Eğer diğer arkadaşlarımız fırsat bulup eklemeleri yapmamışsa müsait olduğumda revize ederim.

Sub Klasor_Kopyala()
    Dim FSO As Object
    Dim Kaynak As String, Hedef As String
    For i = 2 To Range("A" & Rows.Count).End(3).Row
    Kaynak = "C:\Users\PASA KARADAG\Desktop\paket\" & Cells(i, 1).Value
        Hedef = Cells(i, 2).Value
        Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder Kaynak & "*", Hedef, True
    Cells(i, 1).Interior.ColorIndex = 3
    Next
    MsgBox "Klasör kopyalama işlemi tamamlandı!"
End Sub

Ben ekledim hocam artık kopyaladıktan sonra kırmızı oluyor ama tabi siz müsait olduğunuzda yine bi revize ederseniz müthiş olur çok teşekkür ederim emeklerinize sağlık