Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > Diğer Yazılımlar > Windows-Word-PowerPoint....
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Windows-Word-PowerPoint.... Excel haricindeki Ofis programları ile ilgili konular.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 22-01-2015, 12:56   #11
Korhan Ayhan
Moderatör
 
Korhan Ayhan kullanıcısının avatarı
 
Giriş: 15/03/2005
Şehir: ANTALYA
Mesaj: 22,633
Excel Vers. ve Dili:
OFFICE 2013-2016 PRO TR
Varsayılan

Aşağıdaki kodu deneyiniz.

Örnek Dosya


Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Option Explicit

Dim Dosya As String, Aranan As Variant, Klasor As Object
Dim Hedef_Kitap As Workbook, Sayfa As Worksheet, Satir As Long
Dim K1 As Workbook, S1 As Worksheet, Bul As Range, Adres As String
Dim Alt_Klasor As Object, Alt_Dosya As Object, Zaman As Double

Sub KLASORDE_COKLU_KOD_ARAMA()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Liste (Klasor.Items.Item.Path)
    Alt_Liste (Klasor.Items.Item.Path)
    
    S1.Range("A:E").EntireColumn.AutoFit
    
    Set Klasor = Nothing
    Set Bul = Nothing
    Set K1 = Nothing
    Set S1 = Nothing

    Application.ScreenUpdating = True
    
    If Satir > 1 Then
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
    Else
        MsgBox Aranan & " numaralı kod bulunamamıştır!" & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbCritical
    End If
End Sub

Private Sub Liste(Yol As String)
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Aranan = InputBox("Lütfen aradığınız kodu giriniz...", "Kod arama işlemi...")
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    Zaman = Timer
    
    S1.Range("A2:E" & Rows.Count).Clear
    Dosya = Dir(Yol & "\*.xls*")
    
    While Dosya <> ""
        Set Hedef_Kitap = Workbooks.Open(Yol & "\" & Dosya, False, False)
        DoEvents
        For Each Sayfa In Hedef_Kitap.Worksheets
            Set Bul = Sayfa.Cells.Find(Aranan, , , xlWhole)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
                Do
                    Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                    S1.Cells(Satir, 1) = Yol
                    S1.Cells(Satir, 2) = Dosya
                    S1.Cells(Satir, 3) = Sayfa.Name
                    S1.Cells(Satir, 4) = Bul.Address(False, False)
                    S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 5), _
                    Address:=Yol & "\" & Dosya, SubAddress:=Sayfa.Name & "!" & S1.Cells(Satir, 4), _
                    TextToDisplay:="Ulaşmak için tıklayınız..."
                    Set Bul = Sayfa.Cells.FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        Next
        Hedef_Kitap.Close 0
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasor = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasor
        Dosya = Dir(Alt_Dosya.Path & "\*.xls*")
        While Dosya <> ""
            DoEvents
            Set Hedef_Kitap = Workbooks.Open(Alt_Dosya & "\" & Dosya, False, False)
                For Each Sayfa In Hedef_Kitap.Worksheets
                    Set Bul = Sayfa.Cells.Find(Aranan, , , xlWhole)
                    If Not Bul Is Nothing Then
                    Adres = Bul.Address
                        Do
                            Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                            S1.Cells(Satir, 1) = Alt_Dosya
                            S1.Cells(Satir, 2) = Dosya
                            S1.Cells(Satir, 3) = Sayfa.Name
                            S1.Cells(Satir, 4) = Bul.Address(False, False)
                            S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 5), _
                            Address:=Alt_Dosya & "\" & Dosya, SubAddress:=Sayfa.Name & "!" & S1.Cells(Satir, 4), _
                            TextToDisplay:="Ulaşmak için tıklayınız..."
                            Set Bul = Sayfa.Cells.FindNext(Bul)
                        Loop While Not Bul Is Nothing And Bul.Address <> Adres
                    End If
                Next
            Hedef_Kitap.Close True
            Dosya = Dir
        Wend

        Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
End Sub
Eklenmiş Dosyalar
Dosya Türü: xlsm ÖRNEK.xlsm (24.3 KB, 25 Görüntülenme)
__________________
.
.
.

Soru sormadan önce forumumuzun aşağıdaki
bölümlerini incelediğinizde birçok sorunuza yanıt bulabilirsiniz.


Excel Dersanesi
Uygulamalı Excel Eğitimi
Excel İçin Örnek Uygulamalar
Video Dersane (***Altın Üyelere Özel***)

Lütfen sorularınızın çözümlendiğine dair geri dönüş mesajı yazınız...!
Lütfen yazım ve forum kurallarına uyalım...!
Lütfen sorularımızı açık ve net bir dille ifade edelim...!



FORUM KURALLARI
Korhan Ayhan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-01-2015, 17:14   #12
mustilem23
Altın Üye
 
Giriş: 29/10/2010
Şehir: bursa
Mesaj: 280
Excel Vers. ve Dili:
office 2010
Varsayılan

Korhan Bey ilginiz için teşekkür ederim ana klasör ve alt klasörlerde buluyor artık fakat resimde de bahsetmek istediğim gibi bulduğu yoldaki excele git dediğimde aradığım kelimenin üzerinde durmuyor aşağıdaki gibi bir uyarı veriyor .

bundan önceki makroda git dediğimde exceli açıp aradığım kelimenin üzerinde duruyor imleç ,yeni makroda da aynı özelliği ekleyebilmemiz mümkün müdür.

bulduğu
http://www.resimupload.net.tr/image.php?di=KJ0E

eski makro.
http://www.resimupload.net.tr/image.php?di=4HV5
mustilem23 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-01-2015, 23:39   #13
Korhan Ayhan
Moderatör
 
Korhan Ayhan kullanıcısının avatarı
 
Giriş: 15/03/2005
Şehir: ANTALYA
Mesaj: 22,633
Excel Vers. ve Dili:
OFFICE 2013-2016 PRO TR
Varsayılan

Örnek dosyayı ve kodu güncelledim. Tekrar deneyiniz.
__________________
.
.
.

Soru sormadan önce forumumuzun aşağıdaki
bölümlerini incelediğinizde birçok sorunuza yanıt bulabilirsiniz.


Excel Dersanesi
Uygulamalı Excel Eğitimi
Excel İçin Örnek Uygulamalar
Video Dersane (***Altın Üyelere Özel***)

Lütfen sorularınızın çözümlendiğine dair geri dönüş mesajı yazınız...!
Lütfen yazım ve forum kurallarına uyalım...!
Lütfen sorularımızı açık ve net bir dille ifade edelim...!



FORUM KURALLARI
Korhan Ayhan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 23-01-2015, 08:12   #14
mustilem23
Altın Üye
 
Giriş: 29/10/2010
Şehir: bursa
Mesaj: 280
Excel Vers. ve Dili:
office 2010
Varsayılan

Günaydın Korhan Bey ,

sorun giderilmiştir ilginiz için çok teşekkürler.
mustilem23 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 07-02-2015, 18:49   #15
Hyperhysv
Altın Üye
 
Giriş: 23/05/2014
Şehir: istanbul
Mesaj: 92
Excel Vers. ve Dili:
2013 türkçe
Varsayılan

Korhan bey merhabalar;

Bu arama işlemini aynı mantıkla .txt uzantılı dosyalarda yapmak ve dosyanızı bu şekilde modifiye etmek mümkünmü?

yani excel yerine txt uzantılı dosyalarda arama yapmak

teşekkürler
iyi çalışmalar

Bu mesaj en son " 08-02-2015 " tarihinde saat 11:49 itibariyle Hyperhysv tarafından düzenlenmiştir....
Hyperhysv Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-02-2015, 11:49   #16
Hyperhysv
Altın Üye
 
Giriş: 23/05/2014
Şehir: istanbul
Mesaj: 92
Excel Vers. ve Dili:
2013 türkçe
Varsayılan

korhan bey müsait olduğunuzda yardımcı olursanız çok sevinirim.

teşekkürler
Hyperhysv Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-02-2015, 00:28   #17
Korhan Ayhan
Moderatör
 
Korhan Ayhan kullanıcısının avatarı
 
Giriş: 15/03/2005
Şehir: ANTALYA
Mesaj: 22,633
Excel Vers. ve Dili:
OFFICE 2013-2016 PRO TR
Varsayılan

Ekteki dosyayı deneyiniz.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Option Explicit

Dim Klasor As Object, Satir As Long, Zaman As Double, Aranan As Variant
Dim K1 As Workbook, S1 As Worksheet, Dosya As Variant, Dosya_Sistemi As Object
Dim Hedef_Dosya As Object, Bulunan_Satir As Long, Veri As String
Dim Alt_Klasor As Object, Alt_Dosya As Object

Sub KLASORDE_COKLU_KOD_ARAMA()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Liste (Klasor.Items.Item.path)
    Alt_Liste (Klasor.Items.Item.path)
    
    S1.Range("A:D").EntireColumn.AutoFit
    
    Set Klasor = Nothing
    Set K1 = Nothing
    Set S1 = Nothing

    Application.ScreenUpdating = True
    
    If Satir > 1 Then
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
    Else
        MsgBox Aranan & " numaralı kod bulunamamıştır!" & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbCritical
    End If
End Sub

Private Sub Liste(Yol As String)
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Aranan = InputBox("Lütfen aradığınız kodu giriniz...", "Kod arama işlemi...")
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    Zaman = Timer
    
    S1.Range("A2:E" & Rows.Count).Clear
    Dosya = Dir(Yol & "\*.txt*")
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    
    While Dosya <> ""
        Bulunan_Satir = 0
        
        Open Yol & "\" & Dosya For Input As #1
        
        DoEvents
        
        Do Until EOF(1)
            Line Input #1, Veri
            Bulunan_Satir = Bulunan_Satir + 1
            If InStr(1, Veri, Aranan, vbTextCompare) > 0 Then
                Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                S1.Cells(Satir, 1) = Yol
                S1.Cells(Satir, 2) = Dosya
                S1.Cells(Satir, 3) = Bulunan_Satir
                S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                Address:=Yol & "\" & Dosya, SubAddress:="", _
                TextToDisplay:="Ulaşmak için tıklayınız..."
            End If
        Loop
        
        Close #1
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasor = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasor
        Dosya = Dir(Alt_Dosya.path & "\*.txt*")
        While Dosya <> ""
            Bulunan_Satir = 0
        
            Open Alt_Dosya & "\" & Dosya For Input As #1
        
            DoEvents
        
            Do Until EOF(1)
                Line Input #1, Veri
                Bulunan_Satir = Bulunan_Satir + 1
                If InStr(1, Veri, Aranan, vbTextCompare) > 0 Then
                    Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                    S1.Cells(Satir, 1) = Alt_Dosya
                    S1.Cells(Satir, 2) = Dosya
                    S1.Cells(Satir, 3) = Bulunan_Satir
                    S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                    Address:=Yol & "\" & Dosya, SubAddress:="", _
                    TextToDisplay:="Ulaşmak için tıklayınız..."
                End If
            Loop

            Close #1
            Dosya = Dir
        Wend

        Alt_Liste (Alt_Dosya.path)
Devam:
    Next
End Sub
Eklenmiş Dosyalar
Dosya Türü: xlsm ÖRNEK.xlsm (25.2 KB, 22 Görüntülenme)
__________________
.
.
.

Soru sormadan önce forumumuzun aşağıdaki
bölümlerini incelediğinizde birçok sorunuza yanıt bulabilirsiniz.


Excel Dersanesi
Uygulamalı Excel Eğitimi
Excel İçin Örnek Uygulamalar
Video Dersane (***Altın Üyelere Özel***)

Lütfen sorularınızın çözümlendiğine dair geri dönüş mesajı yazınız...!
Lütfen yazım ve forum kurallarına uyalım...!
Lütfen sorularımızı açık ve net bir dille ifade edelim...!



FORUM KURALLARI
Korhan Ayhan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 19-03-2015, 20:48   #18
Hyperhysv
Altın Üye
 
Giriş: 23/05/2014
Şehir: istanbul
Mesaj: 92
Excel Vers. ve Dili:
2013 türkçe
Varsayılan

Sn. Korhan AYHAN açık yüreklilikle söyleyebilirim ki bence altın üyeliğin fiyatı 2 katına çıkarılmalı

teşekkürler ve iyi çalışmalar
Hyperhysv Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-06-2015, 17:05   #19
nozang
Altın Üye
 
Giriş: 11/03/2010
Şehir: istanbul
Mesaj: 174
Excel Vers. ve Dili:
2007 tr
Varsayılan

Alıntı:
Korhan Ayhan tarafından gönderildi Mesajı Görüntüle
Ekteki dosyayı deneyiniz.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Option Explicit

Dim Klasor As Object, Satir As Long, Zaman As Double, Aranan As Variant
Dim K1 As Workbook, S1 As Worksheet, Dosya As Variant, Dosya_Sistemi As Object
Dim Hedef_Dosya As Object, Bulunan_Satir As Long, Veri As String
Dim Alt_Klasor As Object, Alt_Dosya As Object

Sub KLASORDE_COKLU_KOD_ARAMA()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Liste (Klasor.Items.Item.path)
    Alt_Liste (Klasor.Items.Item.path)
    
    S1.Range("A:D").EntireColumn.AutoFit
    
    Set Klasor = Nothing
    Set K1 = Nothing
    Set S1 = Nothing

    Application.ScreenUpdating = True
    
    If Satir > 1 Then
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
    Else
        MsgBox Aranan & " numaralı kod bulunamamıştır!" & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbCritical
    End If
End Sub

Private Sub Liste(Yol As String)
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Aranan = InputBox("Lütfen aradığınız kodu giriniz...", "Kod arama işlemi...")
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    Zaman = Timer
    
    S1.Range("A2:E" & Rows.Count).Clear
    Dosya = Dir(Yol & "\*.txt*")
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    
    While Dosya <> ""
        Bulunan_Satir = 0
        
        Open Yol & "\" & Dosya For Input As #1
        
        DoEvents
        
        Do Until EOF(1)
            Line Input #1, Veri
            Bulunan_Satir = Bulunan_Satir + 1
            If InStr(1, Veri, Aranan, vbTextCompare) > 0 Then
                Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                S1.Cells(Satir, 1) = Yol
                S1.Cells(Satir, 2) = Dosya
                S1.Cells(Satir, 3) = Bulunan_Satir
                S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                Address:=Yol & "\" & Dosya, SubAddress:="", _
                TextToDisplay:="Ulaşmak için tıklayınız..."
            End If
        Loop
        
        Close #1
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasor = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasor
        Dosya = Dir(Alt_Dosya.path & "\*.txt*")
        While Dosya <> ""
            Bulunan_Satir = 0
        
            Open Alt_Dosya & "\" & Dosya For Input As #1
        
            DoEvents
        
            Do Until EOF(1)
                Line Input #1, Veri
                Bulunan_Satir = Bulunan_Satir + 1
                If InStr(1, Veri, Aranan, vbTextCompare) > 0 Then
                    Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                    S1.Cells(Satir, 1) = Alt_Dosya
                    S1.Cells(Satir, 2) = Dosya
                    S1.Cells(Satir, 3) = Bulunan_Satir
                    S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                    Address:=Yol & "\" & Dosya, SubAddress:="", _
                    TextToDisplay:="Ulaşmak için tıklayınız..."
                End If
            Loop

            Close #1
            Dosya = Dir
        Wend

        Alt_Liste (Alt_Dosya.path)
Devam:
    Next
End Sub
KORHAN BEY,
Ben çalıştıramadım konu ile ilgili nasıl bir işlem yapabilirim.?
yardımcı olursanız sevinirim.
saygılarımla.
nozang Çevrimdışı   Alıntı Yaparak Cevapla
Eski 13-06-2015, 01:04   #20
Korhan Ayhan
Moderatör
 
Korhan Ayhan kullanıcısının avatarı
 
Giriş: 15/03/2005
Şehir: ANTALYA
Mesaj: 22,633
Excel Vers. ve Dili:
OFFICE 2013-2016 PRO TR
Varsayılan

Ne gibi bir hata alıyorsunuz?
__________________
.
.
.

Soru sormadan önce forumumuzun aşağıdaki
bölümlerini incelediğinizde birçok sorunuza yanıt bulabilirsiniz.


Excel Dersanesi
Uygulamalı Excel Eğitimi
Excel İçin Örnek Uygulamalar
Video Dersane (***Altın Üyelere Özel***)

Lütfen sorularınızın çözümlendiğine dair geri dönüş mesajı yazınız...!
Lütfen yazım ve forum kurallarına uyalım...!
Lütfen sorularımızı açık ve net bir dille ifade edelim...!



FORUM KURALLARI
Korhan Ayhan Çevrimdışı   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 23:25


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-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden