Sutundaki aynı numaraları seçme

[mahmutbeyli]

Sütündaki aynı veriyi taşıyan hücrelerin satır sonuna kadar (a:g) birlikte renklenmesi yapmak istedim fakat forum benzer dosyalar koşullu biçimlendirme ile yapılmış aynısı yok fakat kod ile yapmak istiyorum örnek dosya ekte yardımlarınız için şimdiden teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub BUL()
    Dim SORU As String, BUL As Range, ADRES As String, SAY As Integer
    SORU = InputBox("Aradığımızı girin", "Bul")
    Cells.Interior.ColorIndex = xlColorIndexNone
    If SORU = "" Then Exit Sub
    Set BUL = Cells.Find(What:=SORU)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Range(ADRES).Select
    Do
    Range("A" & BUL.Row & ":G" & BUL.Row).Interior.ColorIndex = 15
    If Range("G" & BUL.Row).Value < 0 Then Range("G" & BUL.Row).Interior.ColorIndex = 6
    SAY = SAY + 1
    Set BUL = Cells.FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    If SAY = 0 Then MsgBox "Uygun kayıt bulunamamıştır !", vbExclamation, "Dikkat !"
End Sub

 

[mahmutbeyli]

Sn;Korhan Ayhan Hocam,
Teşekkürler...Dua ile