• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

klasör içinde dosya aramak

S

selim5534

Katılım
29 Mart 2016
Mesajlar
54
Excel Vers. ve Dili
türkçe
üstatlar merhaba
bir sorum olacak sizlere
d sürücüsü içinde müşteri klasörü var. ve bu klasör içinde ahmet demir ahmet demirci ve ahmet demirel adında 3 tane dosya oldugunu varsayalım. benim yapmak istediğim ana kayıt dosyasında d1 sütununa ahmet isminin ilk 3 harfini yazdıgımda ve ara düğmesine bastıgımda ahm ilebaşlayan dosyaları listelemek ve ben listeden seçmek isityorum

nasıl windowsta klasör içinde arama yapıyorsak arayacak kelimeyi yazıp aratıyorsak exceldede böyle birşey yapmak istiyorum
biliyorum biraz uzun oldu kusura bakmayın teşekkürler
 
Merhaba,
Aşağıdaki kodu sayfanızın kod penceresine yapıştırıp, D1 hücresinde arama yapınız.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fso As Object, aranan, yol As String, kls As Object
If Not Intersect(Target, [D1]) Is Nothing Then
If Target.Value = "" Then Exit Sub

Set fso = CreateObject("scripting.filesystemobject")
yol = "D:\müşteri\"
Set kls = fso.getfolder(yol)
sat = 2:    Range("D2:D1000").ClearContents
For Each aranan In kls.subfolders
    If aranan.Name Like "*" & Target.Value & "*" Then
        Range("D" & sat).Value = aranan.Name
        sat = sat + 1
    End If
Next aranan
End If
End Sub
 
kodda bir yanlışlık olabilir mi yada ben becerememiş olabilirmiyim bi bakabilirmisiniz
 
kocam kusura bakma o zaman ben yapamamış olabilirim senden ricam bitarif etsen kodu nereye yapıştıracagımızı
 
Sayın antonio kodlarınız klasör aramaya ayarlanmış. O yüzden arkadaşın bulamaması normaldir. Aşağıdaki şekilde denerseniz dosya bulacaktır.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fso As Object, aranan, yol As String, kls As Object
If Not Intersect(Target, [D1]) Is Nothing Then
If Target.Value = "" Then Exit Sub

Set fso = CreateObject("scripting.filesystemobject")
yol = "D:\müşteri\"
Set kls = fso.getfolder(yol)
sat = 2:    Range("D2:D1000").ClearContents
For Each aranan In kls.Files ' subfolders şeklinde olduğunda belirttiğiniz yol içerisinde klasör arar. Ama files yazarsanız klasör içerisinde dosya arar.
    If aranan.Name Like "*" & Target.Value & "*" Then
        Range("D" & sat).Value = aranan.Name
        sat = sat + 1
    End If
Next aranan
End If
End Sub
 
hocam bir kaç sorum daha olacak
1. sorum peki bu koda uyarı ekleye bilirmiyiz
örnek bulunamadı ise böyle bir kayıt bulunamadı buldu ise örnek 5 kayıt bulundu gibi
2.sorum ise bulunan kayıtı tıklayarak yeni seklemede nasıl açabiliriz .
 
1. sorunun cevabı;
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fso As Object, aranan, yol As String, kls As Object
If Not Intersect(Target, [D1]) Is Nothing Then
If Target.Value = "" Then Exit Sub

Set fso = CreateObject("scripting.filesystemobject")
yol = "D:\müşteri\"
Set kls = fso.getfolder(yol)
sat = 2:    Range("D2:D1000").ClearContents
For Each aranan In kls.Files ' subfolders şeklinde olduğunda belirttiğiniz yol içerisinde klasör arar. Ama files yazarsanız klasör içerisinde dosya arar.
    If aranan.Name Like "*" & Target.Value & "*" Then
        Range("D" & sat).Value = aranan.Name
        sat = sat + 1
    End If
Next aranan
End If
if Sat=2 then
     MsgBox "Aranan değer bulunamadı...",vbinformation,"ASKM"
else
    MsgBox Sat-2 & " adet belge bulundu...",vbinformation,"ASKM"
End Sub
2. Soru için köprü eklemek gerekli.
 
bu sefer aynı yere verdiğiniz ikinci kodu yapıştırdım ama kod calışmadı bi bakar mısınız
2. soru otomatik olarak köprü ekleme yapabilirmiyiz
 
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fso As Object, aranan, yol As String, kls As Object
If Not Intersect(Target, [D1]) Is Nothing Then
If Target.Value = "" Then Exit Sub

Set fso = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path & "\" '"D:\müşteri\"
Set kls = fso.getfolder(yol)
Sat = 2:    Range("D2:D1000").ClearContents
For Each aranan In kls.Files ' subfolders şeklinde olduğunda belirttiğiniz yol içerisinde klasör arar. Ama files yazarsanız klasör içerisinde dosya arar.
    If aranan.Name Like "*" & Target.Value & "*" Then
        Range("D" & Sat).Value = aranan.Name
        Range("D" & Sat).Hyperlinks.Add Anchor:=Range("D" & Sat), Address:=aranan.Name
        Sat = Sat + 1
    End If
Next aranan
If Sat = 2 Then
     MsgBox "Aranan değer bulunamadı...", vbInformation, "ASKM"
Else
    MsgBox Sat - 2 & " adet belge bulundu...", vbInformation, "ASKM"
End If
End If
End Sub
 
s.a kodu yazdıgımda d sürücüsündeki müşteri klasörünü bulmuyor bir bakabilirmisiniz masaüstündeki dosyaları buluyor. bir diğere sorum ise dosya ismindeki uzantıyı nasıl gizleye biliriz. teeşkkürler
 
s.a hocam birkaç sorum olacak size kodu yazdıgımda d sürücüsündeki müşteri klasörünü bulmuyor bir bakabilirmisiniz masaüstündeki dosyaları buluyor. bir diğere sorum ise dosya ismindeki uzantıyı nasıl gizleye biliriz. teeşkkürler
kod asagıdadır. teşekkürler



Private Sub Worksheet_Change(ByVal Target As Range)
Dim fso As Object, aranan, yol As String, kls As Object
If Not Intersect(Target, [D1]) Is Nothing Then
If Target.Value = "" Then Exit Sub

Set fso = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path & "\" '"D:\müşteri\"
Set kls = fso.getfolder(yol)
Sat = 2: Range("D2:D1000").ClearContents
For Each aranan In kls.Files ' subfolders şeklinde olduğunda belirttiğiniz yol içerisinde klasör arar. Ama files yazarsanız klasör içerisinde dosya arar.
If aranan.Name Like "*" & Target.Value & "*" Then
Range("D" & Sat).Value = aranan.Name
Range("D" & Sat).Hyperlinks.Add Anchor:=Range("D" & Sat), Address:=aranan.Name
Sat = Sat + 1
End If
Next aranan
If Sat = 2 Then
MsgBox "Aranan değer bulunamadı...", vbInformation, "ASKM"
Else
MsgBox Sat - 2 & " adet belge bulundu...", vbInformation, "ASKM"
End If
End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst