Hazır olan koda klasör için aratma eklemesi

[husnuszr]

merhabalar ;

Elimde böyle bir kod var ;

Sub Dosyaları_kopyala()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")


Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "C:\Users\tasarim\Desktop\HEDEF\", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 1 Then GoTo Atla1

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
ReDim uzanti(10)
uzanti(1) = ".JPG"
uzanti(2) = ".jpg"
uzanti(3) = ".BMP"
uzanti(4) = ".bmp"
uzanti(5) = ".GİF"
uzanti(6) = ".gif"
uzanti(7) = ".pdf"
uzanti(8) = ".PDF"
uzanti(9) = ".dxf"
uzanti(10) = ".DXF"

yol = "C:\Users\tasarim\Desktop\VERİ\" ' resimlerin bulunduğu dosya yolu
For i = 1 To Cells(Rows.Count, "A").End(3).Row
aranan1 = Cells(i, "A").Value
If aranan1 <> "" Then
For j = 1 To 10
Dosya = yol & aranan1 & uzanti(j)

If fL.FileExists(Dosya) = True Then
yeni = Kaynak & "\" & fL.GetFileName(Dosya)
FileCopy Dosya, yeni
Exit For
End If

Next
End If
Next

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

bu kod ile excel a sütunundaki dosya adı numaralarını veri klasörü içerisinde pdf dxf vb. arıyor buluyor hedef klasörüne kopyalıyor.
Ancak veri klasöründeki alt klasörleri aramıyor .
işimi görüyor ancak veri klasörünün içerisinde de klasörler var. Ben tüm klasörlerin içerisinde arama yapıp kaydetmesini istiyorum .
yardımcı olursanız çok sevinirim.

 

[husnuszr]

hep daha araştırıyorum bulamadım bir türlü :S yardımcı olabilir misiniz ? Bilen varsa

 

[husnuszr]

sanırım bilen yok :S