Excel listedeki model isimlerine göre bir dosyadan başka dosyaya resim taşıma

[sezenm06]

Merhaba,
elimde mevcut çalışan bir macro dosyası var. Bu macro yu çalıştırınca listedeki model numaralarının resimlerini kaynak dosyadan belirttiğim dosyaya sorunsuz ama yavaş bir şekilde taşıyor.
Örnek olarak:
Model1
Model2
Model3
şeklinde isme göre tarama yapıp getiriyor.
Eper yapılabilirliği var ise benim ricam şu şekilde:
Ben listemde
Model1
Model2
Mode3 vs diye oluşturduğumda kaynak dosyada bulunan türevlerini de getirsin. Türevler genellikle ilgili modelin diğer resimleri oluyor ve Model1_1
Model1_2
Model1_3 diye gidiyor ve diğer satırlar için de aynı şey geçerli.
Şimdiden yardımlarınız için çok teşekkür ederim.
Ekte

[islakates]

Kod: Tümünü seç

Sub dosya_tasi_hizli()
    Dim kklasor As Object, hklasor As Object
    Dim kaynakklasor As String, hedefklasor As String
    Dim i As Long
    Dim fso As Object
    Dim dosya As Object
    Dim dosyalar As Collection
    Dim modelAdi As String
    Dim anahtar As Variant
    
    Application.ScreenUpdating = False
    
    ' Klasör seçimleri
    Set kklasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Klasörü Seçin", 50, &H0)
    If kklasor Is Nothing Then
        MsgBox "Lütfen Kaynak Klasör Seçin !", vbInformation, "BİLGİ"
        Exit Sub
    End If
    
    Set hklasor = CreateObject("shell.application").BrowseForFolder(0, "Hedef Klasörü Seçin", 50, &H0)
    If hklasor Is Nothing Then
        MsgBox "Lütfen Hedef Klasör Seçin !", vbInformation, "BİLGİ"
        Exit Sub
    End If
    
    kaynakklasor = kklasor.self.Path
    hedefklasor = hklasor.self.Path
    
    If Right(kaynakklasor, 1) <> "\" Then kaynakklasor = kaynakklasor & "\"
    If Right(hedefklasor, 1) <> "\" Then hedefklasor = hedefklasor & "\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dosyalar = New Collection
    
    ' Kaynak klasördeki tüm dosyaları bir kez oku
    For Each dosya In fso.GetFolder(kaynakklasor).Files
        If LCase(fso.GetExtensionName(dosya.Name)) = "jpg" Then
            dosyalar.Add dosya.Name
        End If
    Next dosya
    
    ' Listedeki model adlarını dolaş
    For i = 2 To Range("A65536").End(xlUp).Row
        modelAdi = LCase(Range("A" & i).Value)
        
        For Each anahtar In dosyalar
            ' Model adı ile başlayan tüm dosyalar
            If anahtar Like modelAdi & "*.jpg" Then
                fso.CopyFile kaynakklasor & anahtar, hedefklasor, True
            End If
        Next anahtar
    Next i
    
    MsgBox "Tüm eşleşen dosyalar """ & kaynakklasor & """ adresinden """ & hedefklasor & """ adresine taşındı.", vbInformation, "BİLGİ"
    
    Application.ScreenUpdating = True
End Sub