B ve E hücresinde arama yap,Renklendir.

[k0081]

Merhaba arkadaşlar,,

sadece B ve E hücresinde arama yapan ve bulduğu sonucu renklendiren bir makro oluşturabilirmiyiz.. yeni bir arama yaptığımda önceki rekli kısım kaybolacak.. yani orjinal hücre halinde olacak..
http://hotfile.com/dl/136262977/419ec55/Kitap1.xlsx.html

 

[Necdet]

Merhaba,

Dosyayı neden buraya eklemiyorsunuz da adama ızdırap çektiriyorsunuz?
Sizin dosyayı eklediğiniz yere benim erişim hakkım bile yok?

 

[k0081]

Merhaba,

Dosyayı neden buraya eklemiyorsunuz da adama ızdırap çektiriyorsunuz?
Sizin dosyayı eklediğiniz yere benim erişim hakkım bile yok?

% 95 haklısın.. Siteye ekliyorum..

Ekli dosyayı görüntüle Kitap1.xlsx

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.
Aranan sözcüğün birebir eşleşmesini istiyorsanız kırmızı ile işaretlediğim yerin aynı kalması gerekir, yok içerenleri de arasın derseniz siliniz.

Sub Ara()
    
    Dim ArananSozcuk    As String, _
        c               As Range, _
        Adr             As String
        
    On Error Resume Next
    ArananSozcuk = Application.InputBox("Aradığınız Sözcüğü Giriniz", "Sözcük Girişi")
    If ArananSozcuk = "" Then Exit Sub
    
    Range("B:B,E:E").Font.ColorIndex = xlAutomatic
    With Worksheets(1).Range("B:B,E:E")
        Set c = .Find(ArananSozcuk, LookIn:=xlValues[B][COLOR=red], LookAt:=xlWhole[/COLOR][/B])
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                c.Font.ColorIndex = 3
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    
End Sub

 

[k0081]

Merhaba,

Aşağıdaki kodları deneyiniz.
Aranan sözcüğün birebir eşleşmesini istiyorsanız kırmızı ile işaretlediğim yerin aynı kalması gerekir, yok içerenleri de arasın derseniz siliniz.

Sub Ara()
 
    Dim ArananSozcuk    As String, _
        c               As Range, _
        Adr             As String
 
    On Error Resume Next
    ArananSozcuk = Application.InputBox("Aradığınız Sözcüğü Giriniz", "Sözcük Girişi")
    If ArananSozcuk = "" Then Exit Sub
 
    Range("B:B,E:E").Font.ColorIndex = xlAutomatic
    With Worksheets(1).Range("B:B,E:E")
        Set c = .Find(ArananSozcuk, LookIn:=xlValues[B][COLOR=red], LookAt:=xlWhole[/COLOR][/B])
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                c.Font.ColorIndex = 3
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
End Sub

kodları çalıştırdım. aradığım sözcüğü yazıyorum., Fakat hiç bir değişiklik olmuyor...

 

[Necdet]

Merhaba,

Kodlarda küçük bir değişiklik yaptım, tekrar dener misiniz?

 

[k0081]

Merhaba,

Kodlarda küçük bir değişiklik yaptım, tekrar dener misiniz?

hocam tamamdır.. çok teşekkürler.. sağolasın.. ( üzerinde çalışıp duruyordum.. )

 

[Necdet]

hocam tamamdır.. çok teşekkürler.. sağolasın.. ( üzerinde çalışıp duruyordum.. )

Kolay gelsin