Soru Dosya arama

[ocetinkaya]

Merhabalar,

Bizim serverda ortak dosyamız var o dosya içinde 1.dxf 2.dxf gibi bir çok dosya var

bana ise a sütununda yazılan dosyaları bulup aynı klasör aramasında olduğu gibi listelemesi lazım. Bulunan dosyaları daha sonra manuel olarak buradan alıp başka klasöüre taşıyacağım.

Bu konuda yardımcı olur musunuz?
İyi çalışmalar teşekkürler

 

[ocetinkaya]

güncel

 

[Greenblacksea53]

Sub Klasordeki_dosyalar()
Dim dosya, dc, yol
Set dosya = CreateObject("Scripting.FileSystemObject")
Set yol = dosya.GetFolder("Sizindosyayolunuz")
Set dc = yol.Files
For Each dosya In dc
c = c + 1
Cells(c, 1) = dosya.Name
Next
End Sub

Dosyanızın yolunu "Sizin dosya yolunuz alana yapıştırın. başka klasöre taşımaktan kastınızı anlamadım.

 

[ocetinkaya]

https://imgyukle.com/i/VXk4nQ bu resimdeki gibi bir işlem yapmak istiyorum ara butonuna basınca a sütunundaki dosya isimlerini bulmasını istiyorum

20220624 162558

Resim 20220624 162558 kaydedildi Resim Yükle - Hızlı Resim

imgyukle.com

H
ocam buradaki gibi

A sütunundaki "madde kodu" ile ilişkilendirilmiş dosyalarımız var

 

[ocetinkaya]

güncel

 

[Korhan Ayhan]

Deneyiniz.

Arama yapılacak klasör yolunu (C:\Belgelerim\) bölümünü kendinize göre düzenlersiniz.

Option Explicit

Sub File_Find()
    Dim File_Path As String, X As Long

    File_Path = "C:\Belgelerim\"

    Range("B:B").Clear

    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Dir(File_Path & Cells(X, 1) & ".dxf") <> "" Then Cells(X, 2) = "Bulundu"
    Next

    MsgBox "Arama işlemi tamamlanmıştır." & vbCrLf & vbCrLf & _
           "Bulunan dosya sayısı ; " & Format(WorksheetFunction.CountIf(Range("B:B"), "Bulundu"), "#,##0")
End Sub

 

[ocetinkaya]

@Korhan Ayhan
Merhaba,
Öncelikle yardımınız için teşekkür ederim.

Option Explicit
Sub File_Find()
    Dim File_Path As String, My_File As String, X As Long

    File_Path = "W:\ORTAK ARGE\ARGE_PAYLASIM\"

    Range("G:G").Clear

    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Dir(File_Path & Cells(X, 1) & ".dxf") <> "" Then Cells(X, 2) = "Bulundu"
    Next

    MsgBox "Arama işlemi tamamlanmıştır." & vbCrLf & vbCrLf & _
           "Bulunan dosya sayısı ; " & Format(WorksheetFunction.CountIf(Range("G:G"), "Bulundu"), "#,##0")
End Sub

Verdiğiniz kodu bu şekilde güncelledim.

*Aradığımız dosya uzantısı .dxf ve .dwg uzantılı şeklindedir. Mp3 yazan kısmı dxf olarak güncelledim.

Sizin verdiğiniz kodda dosya var mı yok mu ona bakıyor var ise var yok ise yok mesajı vermektedir.

Benim istediğim ise "G" Sütununda yer alan dosya isimlerini "w" klasöründe arayıp bulacak ve bana windows penceresinde bulduğu dosyaları listeleyecek. Bende o dosyaları başka klasöre manuel olarak taşıyacağım.

Yukarıdaki eklediğim resim gibi sonuç vermesini istiyorum.

Teşekkürler

 

[Korhan Ayhan]

Merhaba,

Ben "mp3" dosyalarında deneme yaptığım için kodun dosya uzantı bölümünü o şekilde bırakmışım. Hatta bir değişkeni fazladan bile bırakmışım. Önerdiğim kodu bu bağlamda revize ettim.

Eğer taşınacak klasör belliyse kod içinde bu işlem otomatik yapılabilir. Yok siz ısrarla ben taşıma işlemini elle yapacağım diyorsanız bulunan dosyalar masaüstünde oluşturulacak yeni klasöre kopyalanır siz oradan elle taşıma işlemini kendiniz yapabilirsiniz. Son kararınız elle taşımak ise kodu revize edebilirim.

 

[Korhan Ayhan]

Aşağıdaki kod şu şekilde çalışıyor.

Kod önce masaüstüne "Taşınacak_Dosyalar" adıyla bir klasör oluşturuyor.
Sonra G sütununda yazan dosya isimlerini tanımlanan klasörde arıyor.
İlgili dosyayı bulursa masaüstünde oluşturulan klasöre kopyalıyor. Bulunduğu klasördeki asıl dosyayı bilerek sildirmedim. Gerekirse dosya sildirilebilir.
Eğer dosya bulunursa işlem bittikten sonra masaüstündeki klasör açılıyor. Dosya bulunamazsa masaüstünde oluşturulan klasör siliniyor.

Option Explicit

Sub File_Find()
    Dim Archive_Path As String, File_Path As String
    Dim File_Extention As String, File_Count As Long
    Dim X As Long

    File_Path = "W:\ORTAK ARGE\ARGE_PAYLASIM\"
    File_Extention = ".dfx"
  
    Archive_Path = Environ("UserProfile") & "\Desktop\Taşınacak_Dosyalar"

    If Dir(Archive_Path, vbDirectory) = "" Then MkDir Archive_Path

    For X = 2 To Cells(Rows.Count, "G").End(3).Row
        If Dir(File_Path & Cells(X, "G") & File_Extention) <> "" Then
            File_Count = File_Count + 1
            FileCopy File_Path & Cells(X, "G") & File_Extention, Archive_Path & "\" & Cells(X, "G") & File_Extention
        End If
    Next

    MsgBox "Arama işlemi tamamlanmıştır." & vbCrLf & vbCrLf & _
           "Bulunan dosya sayısı ; " & Format(File_Count, "#,##0")
         
    If File_Count = 0 Then
        VBA.CreateObject("Scripting.FileSystemObject").DeleteFolder Archive_Path, True
    Else
        Call Shell("Explorer.exe" & " " & Archive_Path, vbNormalFocus)
    End If
End Sub

 

[ocetinkaya]

yardımlarınız için teşekkür ederim