Dosya yolu getirme

[murat_fidan]

Değerli arkadaşlar paylaştığım çalışma ile excelin B sütununa manuel elle istediğim dosya isimlerini yazacağım. Sonra Dosya yolunu getir butonuna tıklayıp B sütununa yazmış olduğum isimlere ait dosyaların bulunduğu (genelde hepsi aynı klasörde) klasörü seçip tamam dediğimde A sütununa yazmış olduğum bu isimlere ait dosyaların yolunu getirecek. Paylaşmış olduğum dosyadaki makro bu şekilde çalışıyor zaten ancak hızı çok yavaş. Bu makroyu revize edebilirmiyiz

 

[Korhan Ayhan]

"genelde hepsi aynı klasörde" bu ifadenize göre farklı klasörlerde olma durumu var sanırım.

Kod iç içe klasörlerde arama yapmak için tasarlanmış. Dosyaların bulunduğu klasörü seçmediğinizde hızlı sonuç vermeyecektir.

Mesela ben şöyle denedim. Tek bir klasör (içinde başka klasör yok) seçtim. Sonuç çok hızlı tamamlandı.
Sonra kullanıcı adımın olduğu klasörü seçtim. Kod hala işlem yapıyor.

Bu sebeple dosyaları bilinen bir klasörde tutmanız işlem süresini kısaltacaktır. Diğer türlü seçiminiz eğer birden çok alt klasör içeriyorsa sürenin kısalması çok mümkün görünmüyor.

Alternatif olarak linklerdeki önerileri deneyebilirsiniz.

Sorgu için arama sonuçları: makro hızlandırma

www.excel.web.tr

 

[murat_fidan]

Korhan bey iç içe klasörde olmayacak sadece sectigim tek klasör içinde olacak zaten paylaştığım çalışma bı sekilde çalışıyor. Bu yolla olacak şekilde nasıl makroyu hızlandırabiliriz

 

[Korhan Ayhan]

Peki seçtğiniz klasörde hangi dosya uzantısı aranacak?

Ek olarak kodun bu haliyle çalışması sizde ne kadar sürüyor?

 

[murat_fidan]

PDF,PNG,XLSM,JPG uzantılı olacak Korhan bey bende 240 adet dosyada denedim yaklaşık 3 dk sürdü

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Write_File_Path()
    Dim My_Folder As Object, My_Path As String
    Dim My_Extension As Variant, My_Data As Variant
    Dim My_File As String, X As Long, Y As Byte, Say As Long
    Dim Process_Time As Double
    
    Range("A2:A" & Rows.Count).ClearContents
    
    Set My_Folder = CreateObject("Shell.Application").BrowseForFolder(0, _
                    "Kaynak dosyaları içeren klasörü seçiniz...", 50, &H0)
    
    If Not My_Folder Is Nothing Then
        Process_Time = Timer
        My_Extension = Array(".pdf", ".png", ".jpg", ".jpeg", ".xlsm")
        My_Data = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Value
        My_Path = My_Folder.Self.Path & "\"
        
        ReDim My_List(1 To Rows.Count, 1 To 1)
        
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            Say = Say + 1
            For Y = LBound(My_Extension) To UBound(My_Extension)
                My_File = Dir(My_Path & "*" & My_Data(X, 1) & "*" & My_Extension(Y))
                If My_File <> "" Then
                    My_List(Say, 1) = My_Path & My_File
                End If
            Next
        Next
    
        If Say > 0 Then
            Range("A2").Resize(Say) = My_List
            Columns.AutoFit
            MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
                   "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
        Else
            MsgBox "Eşleşen dosya bulunamadı!", vbCritical
        End If
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız!", vbExclamation
    End If
End Sub

 

[murat_fidan]

Deneyiniz.

Option Explicit

Sub Write_File_Path()
    Dim My_Folder As Object, My_Path As String
    Dim My_Extension As Variant, My_Data As Variant
    Dim My_File As String, X As Long, Y As Byte, Say As Long
    Dim Process_Time As Double
   
    Range("A2:A" & Rows.Count).ClearContents
   
    Set My_Folder = CreateObject("Shell.Application").BrowseForFolder(0, _
                    "Kaynak dosyaları içeren klasörü seçiniz...", 50, &H0)
   
    If Not My_Folder Is Nothing Then
        Process_Time = Timer
        My_Extension = Array(".pdf", ".png", ".jpg", ".jpeg", ".xlsm")
        My_Data = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Value
        My_Path = My_Folder.Self.Path & "\"
       
        ReDim My_List(1 To Rows.Count, 1 To 1)
       
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            Say = Say + 1
            For Y = LBound(My_Extension) To UBound(My_Extension)
                My_File = Dir(My_Path & "*" & My_Data(X, 1) & "*" & My_Extension(Y))
                If My_File <> "" Then
                    My_List(Say, 1) = My_Path & My_File
                End If
            Next
        Next
   
        If Say > 0 Then
            Range("A2").Resize(Say) = My_List
            Columns.AutoFit
            MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
                   "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
        Else
            MsgBox "Eşleşen dosya bulunamadı!", vbCritical
        End If
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız!", vbExclamation
    End If
End Sub

Korhan bey cevap için öncelikle teşekkür ederim. Makroda şöyle bir sıkıntı oluştu Dosya isimleri metin ise getiriyor,sayılardan oluşuyorsa getirmiyor

 

[Korhan Ayhan]

Şimdi tekrar denedim.

Sayısal ve metinsel dosya isimleri denedim. Sorunsuz listeledi.

Önceki;


Makro çalıştıktan sonra;

 

[murat_fidan]

Şimdi tekrar denedim.

Sayısal ve metinsel dosya isimleri denedim. Sorunsuz listeledi.

Önceki;
Ekli dosyayı görüntüle 236848

Makro çalıştıktan sonra;
Ekli dosyayı görüntüle 236849

Aç kapa yaptım çalıştı Korhan bey teşekkürler

 

[Korhan Ayhan]

Hızlandı mı?

 

[murat_fidan]

Hızlandı mı?

Evet gayet hızlı sonuç verdi