kılasördeki resimleri ayırma

sevensuleyman

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
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.
 
Son düzenleme:

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,794
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Merhaba,
Sayın Askm hocanın gönderdiği bir makro, benim çok işimi gördü, sizin de işinizi görecektir.
Kod:
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

Altın Üye
Katılım
9 Kasım 2012
Mesajlar
193
Excel Vers. ve Dili
office 2010
Altın Üyelik Bitiş Tarihi
08-12-2027
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
 
Üst