kılasördeki resimleri ayırma

[sevensuleyman]

bir klasörde 10.000 adet resim mevcut...
exceldeki listeme göre bu resimleri ayırabilirmiyim. exceldeki veri ile resim isimleri aynı bu resimleri farklı bir klasöre kopyalamak istiyorum
yardımcı olursanız sevinirim.

 

[Tevfik_Kursun]

Merhaba,
Sayın Askm hocanın gönderdiği bir makro, benim çok işimi gördü, sizin de işinizi görecektir.

Sub askm()
Dim ds, f
Set ds = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For i = 12 To Range("B65536").End(3).Row
    belge = ThisWorkbook.Path & "\" & Cells(i, 2) & ".pdf"
    ykonum = ThisWorkbook.Path & "\" & Range("C1") & "\"
    If Dir(ykonum) <> "" Then
    Else
        MkDir ykonum
    End If
        f = ds.MoveFile(belge, ykonum)
Next
End Sub

B sütunuda yazılı olan dosyaları istenen yere götürüyor. Kendinize göre düzenleyebilirsiniz.
İyi çalışmalar

 

[sevensuleyman]

aşagıdaki kodu kullarak çözüldü



Private Sub CommandButton1_Click()

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


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

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
ReDim uzanti(6)
uzanti(1) = ".JPG"
uzanti(2) = ".jpg"
uzanti(3) = ".BMP"
uzanti(4) = ".bmp"
uzanti(5) = ".GİF"
uzanti(6) = ".gif"

yol = "C:\RESIM\" ' 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 6
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