• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Çözüldü Klasör kopyalama macrosu

P

Paşa3535

Katılım
20 Aralık 2023
Mesajlar
23
Excel Vers. ve Dili
2015 turkish
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
 
Affedersiniz ama neden klasör kopyalamak için Excel kullanıyorsunuz?
 
Çü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


 
Klasör kopyalama kodu aşağıdaki gibi.
Kod: 
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.

Kod: 
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
 
Kod: 
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 ?
 
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 :)
 
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.
 
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.
 
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.
 
Örnek dosya paylaşırsanız kod yazmak isteyenler daha hızlı cevap verecektir.
 
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
 
Deneyin.
Kod: 
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
 
Erkan Akayay' Alıntı:
Deneyin.
Kod: 
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
Genişletmek için tıkla ...
Hocam bu klasörün kendisini değil içindekileri kopyaladı . Ben direkt klasörü kopyalasın istiyorum
 
Öncekini ezbere yazdım. Ufak bir şey atlamışım. Şimdi deneyerek gönderiyorum.

Kod: 
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
 
Erkan Akayay' Alıntı:
Öncekini ezbere yazdım. Ufak bir şey atlamışım. Şimdi deneyerek gönderiyorum.

Kod: 
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
Genişletmek için tıkla ...
Çok teşekkür ederim çalışıyor. Kopyalayamadıklarını renklendirebilir miyiz size zahmet
 
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.
 
Erkan Akayay' Alıntı:
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.
Genişletmek için tıkla ...
Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst