Seçilen İsmi Sütunda Aramak

[1Al2Ver]

Merhaba,

Sayfadaki mevcut kod ;

InputBox'a girilen ismi "B2:B2500" arasında arıyor ve bulduklarının zemin rengini sarı yapıyor,

Ancak biçimlendirdiğim (zemini siyah, büyük harfli) hücreleri de değiştirdiğinden font rengi görülemiyor, ayrıca da 2 nci aramaya kadar bu haliyle kalıyor,

Bir başka işlevi ise InputBox'ta arama yapmaktan vaz geçseniz bile, zeminler sarı renk oluyor (ben bunu arzulamıyorum)

İsteğim ;

Bulunanlara zemin rengi değil, kalın kırmızı çerçeve atması ve sayfadan çıkıldığında, kırmızı çerçevenin kalkması yani eski orijinal haline dönmesidir,

Örnekli dosyam ektedir,

Teşekkür ederim.

 

[Muzaffer Ali]

Merhaba.

B sütunun tamamını seçin.
Koşullu biçimlendirme / Yeni Kural seçin.
"... ... ... formül kullan" seçin.
Formül kutusuna =VE($D$4<>"";MBUL($D$4;B1)) bu formülü kopyalayın.
Biçimlendir butonuna tıklatın.
Kenarlık sekmesinden Renk ve Kenarlık seçin. Tamamı tıklatarak pencereleri kapatın.

Artık D4 hücresine yazdığınız kelime B sütununda aranır, bulunursa kenarlık eklenir.
Eğer kenarlıkları eski haline döndürmek isterseniz D4 hücresini temizleyin.

 

[1Al2Ver]

Sayın Muzaffer Ali merhaba,

İlginiz ve öneriniz için teşekkür ederim,

Eğer yanlış bir şey yapmadım ise, formül bu haliyle arananı bulduğu her satıra kenarlık ekliyor, ben örnek dosyadaki gibi sadece dış çerçeve olsun arzuluyorum,

"D4" hücresine ismin tamamını ve birebir aynısını yazmak gerekiyor, kod ile örneğin HAVUÇ yazıp enter ile işlemi gerçekleştire biliyorum.

Olabiliyor ise, makro yardımı ile 1 nolu mesajda arzuladığım gibi sonuç almak istiyorum.

Teşekkür ederim.

 

[Muzaffer Ali]

Dosyanız ekte.
3 koşul ile biçimlendirme yapıldı.

 

[1Al2Ver]

Sayın Muzaffer Ali tekrar merhaba,

Koşullu Biçimlendirme ile desteklenen dosya için teşekkür ederim, bir iki ilave ile istediğime yakın oldu, sağ olun.

Ancak bunu yine de makro ile yapmak istiyorum,

Makrolu bir çözüm önerirseniz memnun olurum,

Teşekkür ederim.

 

[Muzaffer Ali]

Koşullu biçimlendirme ile yapınca her şey otomatik oluyor. Kod ile yapınca koşullu biçimlendirmenin yaptığı işlemin aynısını kod ile yapmak gerekiyor onun için hem gereksiz hem de gereksiz yere çok uzun kod yazılmalı. Yani zaten excelde var olan bir özelliğin aynısını yeniden kod yazarak yapmak mantıklı görünmüyor.

Eğer kod ile yapmak istemenizin bir sebebi varsa söylerseniz belki farklı pratik bir çözüm bulunabilir.

 

[1Al2Ver]

Sayın Muzaffer Ali tekrar merhaba,

Açıklamalar için teşekkür ederim.

Saygılarımla.

 

[Korhan Ayhan]

Alternatif makrolu çözüm..

Kodun sağlıklı çalışması için YEMEK isimlerinizin benzersiz olmasına özen gösteriniz..

Boş bir modüle;

Option Explicit

Sub Food_Find()
    Dim S1 As Worksheet, Rng As Range, Search_Text As Variant
    Dim Find_Data As Range, First_Address As String
    Dim Food_Name As Object, My_Item As Variant, X As Integer
    Dim Data_Last_Row As Long, Last_Row As Long
    Dim Process_Time As Double, My_Formula As String
    
    Search_Text = Application.InputBox("Aradığınız veriyi giriniz...")
    
    If Search_Text = "" Then
        MsgBox "Lütfen aramak istediğiniz veriyi giriniz!", vbExclamation
        Exit Sub
    End If
    
    If Search_Text = False Then
        MsgBox "İşleminiz iptal edilmiştir.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Process_Time = Timer
    
    Set S1 = Sheets("VERİ")
    Set Food_Name = VBA.CreateObject("Scripting.Dictionary")
    
    Last_Row = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
    For Each Rng In S1.Range("B2:B" & Last_Row)
        Food_Name.Item(Rng.Value) = False
    Next

    For Each My_Item In Food_Name.Keys
        Set Find_Data = S1.Range("B:B").Find(What:=My_Item, LookAt:=xlPart)
        
        If Not Find_Data Is Nothing Then
            First_Address = Find_Data.Address
            Do
                My_Formula = "LOOKUP(2,1/('" & S1.Name & "'!B1:B1048576=""" & Find_Data.Value & """),ROW('" & S1.Name & "'!B1:B1048576))"
                My_Formula = Replace(My_Formula, 1048576, Last_Row)
                Data_Last_Row = Evaluate(My_Formula)
                S1.Range("B" & Find_Data.Row & ":B" & Data_Last_Row).BorderAround 1, xlThin, 0
            
                Set Find_Data = S1.Range("B:B").Find(What:=My_Item, After:=S1.Cells(Data_Last_Row, "B")(1), LookAt:=xlPart)
            Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
        End If
    Next

    Set Find_Data = S1.Range("B:B").Find(What:=Search_Text, LookAt:=xlPart)
    
    If Not Find_Data Is Nothing Then
        First_Address = Find_Data.Address
        Do
            My_Formula = "LOOKUP(2,1/('" & S1.Name & "'!B1:B1048576=""" & Find_Data.Value & """),ROW('" & S1.Name & "'!B1:B1048576))"
            My_Formula = Replace(My_Formula, 1048576, Last_Row)
            Data_Last_Row = Evaluate(My_Formula)
            S1.Range("B" & Find_Data.Row & ":B" & Data_Last_Row).BorderAround 1, xlMedium, 3
            X = X + 1
            Set Find_Data = S1.Range("B:B").Find(What:=Search_Text, After:=S1.Cells(Data_Last_Row, "B")(1), LookAt:=xlPart)
        Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
    End If
    
    Application.Goto Reference:=S1.Range(First_Address).Offset(, -1), Scroll:=True
    ActiveCell.Next.Select
    
    If ActiveWindow.ActivePane.ScrollRow <= ActiveCell.Row Then
        ActiveWindow.SmallScroll Down:=ActiveCell.Row - ActiveWindow.ActivePane.ScrollRow - (Windows(1).VisibleRange.Rows.Count / 2)
    End If

    Set S1 = Nothing
    Set Food_Name = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox Format(X, "#,##0") & " adet yemek bulunmuştur." & vbCrLf & _
          "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

Sub None_Color()
    Dim S1 As Worksheet, Rng As Range, My_Formula As String
    Dim Find_Data As Range, First_Address As String
    Dim Food_Name As Object, My_Item As Variant, X As Integer
    Dim Data_Last_Row As Long, Last_Row As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("VERİ")
    Set Food_Name = VBA.CreateObject("Scripting.Dictionary")
    
    Last_Row = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
    For Each Rng In S1.Range("B2:B" & Last_Row)
        Food_Name.Item(Rng.Value) = False
    Next

    For Each My_Item In Food_Name.Keys
        Set Find_Data = S1.Range("B:B").Find(What:=My_Item, LookAt:=xlPart)
        
        If Not Find_Data Is Nothing Then
            First_Address = Find_Data.Address
            Do
                My_Formula = "LOOKUP(2,1/('" & S1.Name & "'!B1:B1048576=""" & Find_Data.Value & """),ROW('" & S1.Name & "'!B1:B1048576))"
                My_Formula = Replace(My_Formula, 1048576, Last_Row)
                Data_Last_Row = Evaluate(My_Formula)
                S1.Range("B" & Find_Data.Row & ":B" & Data_Last_Row).BorderAround 1, xlThin, 0
            
                Set Find_Data = S1.Range("B:B").Find(What:=My_Item, After:=S1.Cells(Data_Last_Row, "B")(1), LookAt:=xlPart)
            Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
        End If
    Next
    
    Set S1 = Nothing
    Set Food_Name = Nothing
    
    Application.ScreenUpdating = True
End Sub

VERİ isimli sayfanızın kod bölümüne;

Option Explicit

Private Sub Worksheet_Deactivate()
    Call None_Color
End Sub

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Öncelikle ilginiz ve hassasiyetiniz için çok teşekkür ederim, sağ olun.

Olabiliyor ise küçük bir ricam var, malum 2500 satırlık bir veri,

Kod bulup çerçeve içine aldığı yemeğin bulunduğu adrese ( aşağı kaydırma ) gidebilir mi ?

Ekli dosya "VERİ" sayfasında Örnek ; Tas Kebabı arandı, 584:594 ncü satırlarda bulundu, ben PgDn yapmadan bunu ekranda görmek istiyorum,

Teşekkür ederim.

 

[Korhan Ayhan]

Amaç ilgili yemeği görmekse sadece filtre yeterli olurdu gibime geliyor.

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Teşekkür ederim,

Saygılarımla.

 

[Korhan Ayhan]

Bulunan YEMEK adına ilişkin hücrenin seçilerek ekranda görünmesiyle ilgili durum için kodu revize ettim.

Deneyip sonucu bildirirsiniz.

 

[1Al2Ver]

Sayın Korhan Ayhan tekrar merhaba,

Emeğinize sağlık,

Revize edilmiş kod arzuladığım işlemi gerçekleştirmektedir, teşekkür ederim.

Saygılarımla.