Klasördeki Dosyaları Taşıma

[Feylosof]

Herkese selamlarımı iletiyorum.
Aşağıda @halit3 üstadımızın bir kodunu ekledim. Bu kod bir klasörden diğer bir klasöre dosyaları kopyalıyor. Benim yapmak istediğim kaynak klasörü boşaltarak taşısın.

Dim Kaynak2

Sub Dosyaları_kopyala()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla1

Set Klasor2 = CreateObject("shell.application").BrowseForFolder(0, "Hedef Klasörü Seçin", 50, &H0)
If Not Klasor2 Is Nothing Then
Kaynak2 = Klasor2.self.Path
If InStr(1, Kaynak2, "{") > 0 Then GoTo Atla2

Liste (Kaynak)
Set Klasor2 = Nothing

MsgBox "işlem tamam"
Else
Atla2:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Klasor = Nothing

Else
Atla1:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"
For Each Dosya In fL.GetFolder(yol).Files
eski = fL.GetFile(Dosya)
yeni = Kaynak2 & "\" & fL.GetFileName(Dosya)
FileCopy eski, yeni
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next
End Sub

 

[Feylosof]

İkinci merak ettiğim konu sadece PDF dosyalarını taşıyacak şekilde düzenlenebilir mi?

 

[halit3]

kod:

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"
For Each dosya In fL.GetFolder(yol).Files
eski = fL.GetFile(dosya)

If LCase(fL.GetExtensionName(dosya)) = "pdf" Then
yeni = Kaynak2 & "\" & fL.GetFileName(dosya)
'FileCopy eski, yeni
Name eski As yeni
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next
End Sub

 

[Feylosof]

Değerli @halit3 üstadım. tam istediğim gibi var olun. Teşekkürler