Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 28-10-2017, 23:18   #1
selim5534
 
Giriş: 29/03/2016
Şehir: istanbul
Mesaj: 42
Excel Vers. ve Dili:
türkçe
Varsayılan klasör içinde dosya aramak

ü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
selim5534 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-10-2017, 23:38   #2
antonio
Destek Ekibi
 
antonio kullanıcısının avatarı
 
Giriş: 13/02/2011
Mesaj: 1,031
Excel Vers. ve Dili:
Excel 2013
Varsayılan

Merhaba,
Aşağıdaki kodu sayfanızın kod penceresine yapıştırıp, D1 hücresinde arama yapınız.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
Özel mesaj sistemini devre dışı bıraktım.
Yardım istemeden önce Forum Kurallarını okuyunuz.
Aynı konuyu farklı bölümlerde açanların sorularını yanıtlamıyorum, bu durumu fark etmeden yanıtlamışsam, mesajımı siliyorum.
antonio Çevrimdışı   Alıntı Yaparak Cevapla
Eski 31-10-2017, 20:48   #3
selim5534
 
Giriş: 29/03/2016
Şehir: istanbul
Mesaj: 42
Excel Vers. ve Dili:
türkçe
Varsayılan

kodda bir yanlışlık olabilir mi yada ben becerememiş olabilirmiyim bi bakabilirmisiniz
selim5534 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 31-10-2017, 21:01   #4
antonio
Destek Ekibi
 
antonio kullanıcısının avatarı
 
Giriş: 13/02/2011
Mesaj: 1,031
Excel Vers. ve Dili:
Excel 2013
Varsayılan

Alıntı:
selim5534 tarafından gönderildi Mesajı Görüntüle
kodda bir yanlışlık olabilir mi yada ben becerememiş olabilirmiyim bi bakabilirmisiniz
Kodun çalıştığından eminim, çünkü test ettikten sonra gönderdim.
__________________
Özel mesaj sistemini devre dışı bıraktım.
Yardım istemeden önce Forum Kurallarını okuyunuz.
Aynı konuyu farklı bölümlerde açanların sorularını yanıtlamıyorum, bu durumu fark etmeden yanıtlamışsam, mesajımı siliyorum.
antonio Çevrimdışı   Alıntı Yaparak Cevapla
Eski 31-10-2017, 21:15   #5
selim5534
 
Giriş: 29/03/2016
Şehir: istanbul
Mesaj: 42
Excel Vers. ve Dili:
türkçe
Varsayılan

kocam kusura bakma o zaman ben yapamamış olabilirim senden ricam bitarif etsen kodu nereye yapıştıracagımızı
selim5534 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 31-10-2017, 21:56   #6
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,620
Excel Vers. ve Dili:
2010-2016
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 05-11-2017, 15:15   #7
selim5534
 
Giriş: 29/03/2016
Şehir: istanbul
Mesaj: 42
Excel Vers. ve Dili:
türkçe
Varsayılan

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 .
selim5534 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-11-2017, 20:07   #8
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,620
Excel Vers. ve Dili:
2010-2016
Thumbs up

1. sorunun cevabı;
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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.
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 05-11-2017, 21:27   #9
selim5534
 
Giriş: 29/03/2016
Şehir: istanbul
Mesaj: 42
Excel Vers. ve Dili:
türkçe
Varsayılan

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
selim5534 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-11-2017, 22:00   #10
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,620
Excel Vers. ve Dili:
2010-2016
Varsayılan

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 13:27


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri- Çorlu Çelik Konstruksiyon-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden