Belirli kelime ve rakamları iki sütunda bul renklendir.

Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Sa. kolay gelsin başlıkta da anlattığım gibi elimde belli kelimeler var bunları tek seferde iki sütunda aratıp o satırları renklendirmesini istiyorum. Örnek aradım ama bulamadım yardımcı olursanız çok sevinirim. Örneğin arayacağım kelimeler ( Ali Ahmet Elma Armut 112 155 wb...) bu ve benzeri arayacağım kelimeleri E:E ve K:K sütunlarında arayıp bulunca satırları renklendirmesi. İnşallah anlatabilmişimdir şimdiden teşekkür ederim.
 

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
552
Excel Vers. ve Dili
Office365 TR
Aşağadaki kod https://stackoverflow.com/questions/30384067/how-to-find-multiple-strings-in-vba sitesinden alınmıştır.

Kod:
Sub Sample()
    Dim MyAr(1 To 4) As String  'aranacak kelime sayısı kaç ise 4 sayısı ile değiştiriniz. Bu örnekte 4 kelime araması yapıyor.
    Dim ws As Worksheet
    Dim aCell As Range, bCell As Range
    Dim i As Long

    Set ws = ThisWorkbook.ActiveSheet
    
    MyAr(1) = "Ali"
    MyAr(2) = "Ahmet"
    MyAr(3) = "Elma"
    MyAr(4) = "Armut"  'aranacak kelimeleri alt alta bu şekilde yazınız MyAr(5), MyAr(6)  vb.
    With ws
        '~~> Loop through the array  E sütunu
        For i = LBound(MyAr) To UBound(MyAr)
            Set aCell = .Columns(5).Find(What:=MyAr(i), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not aCell Is Nothing Then
                Set bCell = aCell
                aCell.Interior.ColorIndex = 3

                Do
                    Set aCell = .Columns(5).FindNext(After:=aCell)

                    If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        aCell.Interior.ColorIndex = 3
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Next
    End With
    
    With ws
        '~~> Loop through the array  K sütunu
        For i = LBound(MyAr) To UBound(MyAr)
            Set aCell = .Columns(11).Find(What:=MyAr(i), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not aCell Is Nothing Then
                Set bCell = aCell
                aCell.Interior.ColorIndex = 3  'sadece hücreyı kırmızıya boyar
                'aCell.EntireRow.Interior.ColorIndex = 4 satırı yeşile boyar (satırı boyamak istiyorsanız üst satırdakı kodu ve bu satırın başındaki ' <=  siliniz.)

                Do
                    Set aCell = .Columns(11).FindNext(After:=aCell)

                    If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        aCell.Interior.ColorIndex = 3
                      ' aCell.EntireRow.Interior.ColorIndex = 4 satırı yeşile boyar (satırı boyamak istiyorsanız üst satırdakı kodu ve bu satırın başındaki ' <=  siliniz.)
                        
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Next
    End With
End Sub
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makroyu deneyiniz (Büyük küçük harf duyarlıdır):

PHP:
Sub renklendir()
sonE = Cells(Rows.Count, "E").End(3).Row
sonK = Cells(Rows.Count, "K").End(3).Row
son = WorksheetFunction.Max(sonE, sonK)
aranan = InputBox("Aranacak veriyi giriniz")

If WorksheetFunction.CountIf(Range("E1:E" & sonE), aranan) = 0 And _
    WorksheetFunction.CountIf(Range("K1:K" & sonK), aranan) = 0 Then
    MsgBox "Aranan veri E ve K sütunlarında dulunmamaktadır!", vbInformation
    Exit Sub
End If
    
eski = MsgBox("Eski renklendirmeler iptal edilsin mi?", vbYesNo)

If eski = vbYes Then
    Range("E1:E" & sonE).Interior.Color = xlNone
    Range("K1:K" & sonE).Interior.Color = xlNone
End If

If WorksheetFunction.CountIf(Range("E1:E" & sonE), aranan) > 0 Then
    For Each hucre In Range("E1:E" & sonE)
        If hucre = aranan Then
            hucre.Interior.Color = vbRed
        End If
    Next
End If
If WorksheetFunction.CountIf(Range("K1:K" & sonK), aranan) > 0 Then
    For Each hucre In Range("K1:K" & sonK)
        If hucre = aranan Then
            hucre.Interior.Color = vbRed
        End If
    Next
End If
End Sub
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,520
Excel Vers. ve Dili
Office 365 Türkçe
Merhaba , alternatif olarak..

Kod:
Sub Bul_Boya()
    Dim Rng, Veri, AraBul, Bul, firstAddress
    Set Rng = Application.Range(Cell1:="E1:E1000", Cell2:="K1:K1000")
    Veri = InputBox("Aranacak veriyi giriniz")
    AraBul = Split(Veri, ",")
    If Veri <> "" Then
        Rng.Interior.Pattern = xlNone
        For i = 0 To UBound(AraBul)
            If AraBul(i) <> "" Then
                Set Bul = Rng.Find(AraBul(i), , xlValues, xlWhole)
                If Not Bul Is Nothing Then
                    firstAddress = Bul.Address
                    Do: Bul.Interior.Color = 255: Set Bul = Rng.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> firstAddress
                End If
            End If
        Next
    End If
End Sub
 
Son düzenleme:
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
muratboz06 bey gönderdiğiniz kodu denedim fakat arama işlemini yapmadı
YUSUF44 ve EmrExcel16 beyin attığı kodlar tek tek aramak için uygun ama çoklu tek seferde aramaya uygun değil sanırım
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
muratboz06 işe yaradı teşekkür ederim
İlgilenen arkadaşlarada teşekkürler umarım başkalarınında işine yarar iyi çalışmalar
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,520
Excel Vers. ve Dili
Office 365 Türkçe
muratboz06 bey gönderdiğiniz kodu denedim fakat arama işlemini yapmadı
YUSUF44 ve EmrExcel16 beyin attığı kodlar tek tek aramak için uygun ama çoklu tek seferde aramaya uygun değil sanırım
Merhaba , #5 nolu mesajımdaki kodları bu doğrultuda güncelledim , kelimelerin aralarına ","(virgül) ekleyerek çoklu arama yapabilirsiniz..
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
İsterseniz aranacak kelimeleri bir sütuna yazıp o sütundaki kelimelerin aratılması sağlanabilir ki bence bu daha pratik olur.
 
Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Çok teşekkürler her ikisi de iş gördü elinize emeğinize sağlık.
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Sn. @YUSUF44 Bu şekilde yapabilirsek daha kullanışlı olur bencede, Şimdiden elinize sağlık.
Aşağıdaki haliyle Q sütunundaki veriler E ve K sütununda aranıp boyanır:

PHP:
Sub renklendir()
sonE = Cells(Rows.Count, "E").End(3).Row
sonK = Cells(Rows.Count, "K").End(3).Row
sonQ = Cells(Rows.Count, "Q").End(3).Row

son = WorksheetFunction.Max(sonE, sonK)
bul = 0

eski = MsgBox("Eski renklendirmeler iptal edilsin mi?", vbYesNo)

If eski = vbYes Then
    Range("E1:E" & sonE).Interior.Color = xlNone
    Range("K1:K" & sonE).Interior.Color = xlNone
End If

For Each hucre In Range("E1:E" & sonE)
    If WorksheetFunction.CountIf(Range("Q1:Q" & sonQ), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("K1:K" & sonK)
    If WorksheetFunction.CountIf(Range("Q1:Q" & sonQ), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

If bul = 0 Then
    MsgBox "Aranan veriler E ve K sütunlarında bulunamamıştır!", vbInformation
Else
    MsgBox bul & " adet veri bulunup boyandı!", vbInformation
End If

End Sub
 

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
Sayın @YUSUF44 , öncelikle verdiğiniz cevap için çok teşekkür ederim, Q sütununda aranan kelimelerin geçtiği E ve K sütunundaki (Adres içinden) satırların renklendirilmesini istersek yani cümle içinden kelime arayıp bulunan satırları renklendirebilir miyiz, yada sadece aranan kelimelerin kendisini renklendirebilir miyiz. Teşekkürler.
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makro belirtilen arama işlemini yapıp olduğu satırı A:Z aralığında boyar:

Kod:
Sub renklendir()
sonE = Cells(Rows.Count, "E").End(3).Row
sonK = Cells(Rows.Count, "K").End(3).Row
sonQ = Cells(Rows.Count, "Q").End(3).Row

son = WorksheetFunction.Max(sonE, sonK)
bul = 0

eski = MsgBox("Eski renklendirmeler iptal edilsin mi?", vbYesNo)

If eski = vbYes Then
    Range("E1:Z" & son).Interior.Color = xlNone
End If

For Each hucre In Range("E1:E" & sonE)
    If WorksheetFunction.CountIf(Range("Q1:Q" & sonQ), hucre) > 0 Then
        Range("A" & hucre.Row & ":Z" & hucre.Row).Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("K1:K" & sonK)
    If WorksheetFunction.CountIf(Range("Q1:Q" & sonQ), hucre) > 0 Then
        Range("A" & hucre.Row & ":Z" & hucre.Row).Interior.Color = vbRed
        bul = bul + 1
    End If
Next

If bul = 0 Then
    MsgBox "Aranan veriler E ve K sütunlarında bulunamamıştır!", vbInformation
Else
    MsgBox bul & " adet veri bulunup satırı boyandı!", vbInformation
End If

End Sub
 

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
Sn. @YUSUF44 Cevabınız için teşekkürler, ancak Sorum yanlış anlaşılmış olacak, ben Q sütununda kelimeleri arayacak E ve K sütunundaki cümle içinde diyelim ki bu iki sutunda benim adres bilgilerim var Hürriyet Mah. Orkide sokak No. 5 GAZİOSMANPAŞA/İSTANBUL, ben Q sütununda Orkide diye yazıp arattırdığımda Bütün Orkide geçen hücreler boyansın şeklinde istemiştim. Hatta aradığımız ve bulduğu bütün Orkide kelimesi boyansa daha da güzel olur. Teşekkür ederim.
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi deneyin:

PHP:
Sub renklendir()
sonE = Cells(Rows.Count, "E").End(3).Row
sonK = Cells(Rows.Count, "K").End(3).Row
sonQ = Cells(Rows.Count, "Q").End(3).Row

son = WorksheetFunction.Max(sonE, sonK)
bul = 0

For i = 1 To sonQ
    For Each hucre In Range("E1:E" & sonE)
        If Len(hucre) <> Len(Replace(hucre, Cells(i, "Q"), "")) Then
            For j = 1 To Len(hucre)
                If Mid(hucre, j, Len(Cells(i, "Q"))) = Cells(i, "Q") Then
                    hucre.Characters(Start:=j, Length:=Len(Cells(i, "Q"))).Font.Color = vbRed
                End If
                bul = bul + 1
            Next
        End If
    Next

    For Each hucre In Range("K1:K" & sonK)
        If Len(hucre) <> Len(Replace(hucre, Cells(i, "Q"), "")) Then
            For j = 1 To Len(hucre)
                If Mid(hucre, j, Len(Cells(i, "Q"))) = Cells(i, "Q") Then
                    hucre.Characters(Start:=j, Length:=Len(Cells(i, "Q"))).Font.Color = vbRed
                End If
                bul = bul + 1
            Next
        End If
    Next
Next
    
If bul = 0 Then
    MsgBox "Aranan veriler E ve K sütunlarında bulunamamıştır!", vbInformation
Else
    MsgBox bul & " adet veri bulunup satırı boyandı!", vbInformation
End If

End Sub
 

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
Sn. @YUSUF44 kardeşim hakkını helal et, elinize sağlık tam istediğim gibi oldu, renklendirme ile ilgili bir hayli bilgimiz oldu. Çok çok teşekkür ediyorum. Sağ olasınız.
 
Katılım
25 Kasım 2012
Mesajlar
107
Excel Vers. ve Dili
Office 2013
selamlar;
kodu şu şekilde uygulamamız mümkün mü sn: @YUSUF44
benim yapmış olduğum tabloda a sütunundan l sütununa kadar değerler var
benim Q sütununa girdiğim değerleri içeren hücreler boyansın istiyorum.
yukardaki kodları denedim olmadı.
ayrıca numara olarak girdiğim değerlerde boyanmadı
şimdiden teşekkürler



Merhaba,

Dosyanızda sayfa koruması olabilir, kontrol ediniz. Varsa kaldırıp gözlemleyiniz.

İyi çalışmalar.
Aşağıdaki gibi deneyin:

PHP:
Sub renklendir()
sonE = Cells(Rows.Count, "E").End(3).Row
sonK = Cells(Rows.Count, "K").End(3).Row
sonQ = Cells(Rows.Count, "Q").End(3).Row

son = WorksheetFunction.Max(sonE, sonK)
bul = 0

For i = 1 To sonQ
    For Each hucre In Range("E1:E" & sonE)
        If Len(hucre) <> Len(Replace(hucre, Cells(i, "Q"), "")) Then
            For j = 1 To Len(hucre)
                If Mid(hucre, j, Len(Cells(i, "Q"))) = Cells(i, "Q") Then
                    hucre.Characters(Start:=j, Length:=Len(Cells(i, "Q"))).Font.Color = vbRed
                End If
                bul = bul + 1
            Next
        End If
    Next

    For Each hucre In Range("K1:K" & sonK)
        If Len(hucre) <> Len(Replace(hucre, Cells(i, "Q"), "")) Then
            For j = 1 To Len(hucre)
                If Mid(hucre, j, Len(Cells(i, "Q"))) = Cells(i, "Q") Then
                    hucre.Characters(Start:=j, Length:=Len(Cells(i, "Q"))).Font.Color = vbRed
                End If
                bul = bul + 1
            Next
        End If
    Next
Next
   
If bul = 0 Then
    MsgBox "Aranan veriler E ve K sütunlarında bulunamamıştır!", vbInformation
Else
    MsgBox bul & " adet veri bulunup satırı boyandı!", vbInformation
End If

End Sub
 
Üst