Excel VBA Çoklu Ara, Bul, Renklendir


Noktalı virgülle ayrılmış anahtar kelimeleri bu karakterden böler ve her anahtar kelime için arama yapar. Eğer eşit değer bulursa renk dizisinde verilen renk indekslerinden birisi sırasıyla kullanılarak renklendirilir.

Kod
Option Explicit

Sub AraBulRenklendirCokluAlan()
    Dim aranan     As String
    Dim aramaAlani As Range
    Dim hucre      As Range
    Dim arananDizi As Variant
    Dim renkIndeks As Variant
    Dim i As Long
    
    Set aramaAlani = Range("A1:G25")
    aramaAlani.Interior.ColorIndex = xlNone
    
    renkIndeks = Array(3, 4, 5, 6, 7, 8, _
                       10, 12, 14, 15, 16, _
                       17, 18, 22, 23, 26, 27)
    
    aranan = InputBox("Aranan: ")
        
    arananDizi = Split(aranan, ";")
    
    For Each hucre In aramaAlani
        For i = LBound(arananDizi) To UBound(arananDizi)
            If (hucre.Text = arananDizi(i)) Then
                hucre.Interior.ColorIndex = renkIndeks(i)
            End If
        Next
    Next
End Sub
Kod (Açıklamalı)
Option Explicit

Sub AraBulRenklendirCokluAlan()
    Dim aranan     As String
    Dim aramaAlani As Range
    Dim hucre      As Range
    Dim arananDizi As Variant
    Dim renkIndeks As Variant
    Dim i          As Long
    
    '--------------------------------------------------
    'Arama yapılacak alanı ayarladık.
    '--------------------------------------------------
    Set aramaAlani = Range("A1:G25")
    
    '--------------------------------------------------
    'Arama yapılacak alandaki arkaplan renklerini
    'karışıklık yaşanmaması için sildik.
    '--------------------------------------------------
    aramaAlani.Interior.ColorIndex = xlNone
    
    '--------------------------------------------------
    'Standart excel düzenine göre hem renklendirmesi
    'iyi olan, hem de yazıyı boğmayan bir renk listesi
    'hazırladım. Siz duruma göre değiştirebilirsiniz.
    'Bunu da dizi olarak kullanacağız.
    '--------------------------------------------------
    renkIndeks = Array(3, 4, 5, 6, 7, 8, _
                       10, 12, 14, 15, 16, _
                       17, 18, 22, 23, 26, 27)
    
    '--------------------------------------------------
    'Anahtar kelimeleri noktalı virgülle ayırarak
    'giriyoruz. Sonra bu karakterden bölüp tek tek
    'aratabileceğiz.
    '--------------------------------------------------
    aranan = InputBox("Aranan: " & vbCrLf & _
                "(Birden fazla arama yapmak için anahtar kelimelerin arasına noktalı virgül ekleyin.)")
        
    '--------------------------------------------------
    'InputBox aracılığıyla kullanıcıdan gelen veriyi
    'Split ile böldük. Bu metod bölünen metni dizi olarak
    'saklıyor. Biz de kendi tanımladığımız değişkeni
    'kullanmak istediğimizden dolayı Split sonucunu
    'kendi dizi değişkenimize aktardık.
    '--------------------------------------------------
    arananDizi = Split(aranan, ";")
    
    '--------------------------------------------------
    'Verilen alandaki her hücre için kontrol yapıyoruz.
    '--------------------------------------------------
    For Each hucre In aramaAlani
    
        '--------------------------------------------------
        'Hücreyi her arama kelimesi için kontrol ediyoruz.
        '--------------------------------------------------
        For i = LBound(arananDizi) To UBound(arananDizi)
        
            '--------------------------------------------------
            'Eğer anahtar kelimelerden biri hücredeki
            'değere eşitse renklendirme yap.
            '
            'Bu arada renkIndeks dizisinden fazla anatar
            'kelime girilmişse hata verecektir, siz
            'artık buna göre ayarlama yaparsınız.
            'Mesela renk indeks dizisine 
            'renk indeksi eklemek,
            'RGB renkleri kullanmak gibi.
            '--------------------------------------------------
            If (hucre.Text = arananDizi(i)) Then
                hucre.Interior.ColorIndex = renkIndeks(i)
            End If
        Next
    Next
End Sub

Bunlar da hoşunuza gidebilir...


Bir cevap yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir