Daha Önce BelİrledİĞİmİz DeĞerler Kirmizi Renk Yazilsin

[ozgurpeh]

Arkadaşlar Merhaba;

60 hücrelik bir çalışmada önceden belirlediğimiz (Örnek :aa,bb,cc,dd,ee,ff,gg,hh,ıı,jj) değer bu 60 hücrenin neresine yazılırsa yazılsın kırmızı renge macro ile nasıl dönüştürebiliriz. ???

 

[baydeniro]

Merhaba özgürpeh. İsteğiniz çok kolay da bir dosya ekleyin. Hangi değerler olacağını tabii örnek olarak yazın.

 

[ozgurpeh]

Merhaba özgürpeh. İsteğiniz çok kolay da bir dosya ekleyin. Hangi değerler olacağını tabii örnek olarak yazın.

BUYRUN ÖRNEK EKTE DETAYDA BELİRTTİM

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub BICIMLE()
For Each RENK In Range("A1:A60")
RENK.Interior.ColorIndex = xlNone
For SAY = 0 To 2
DEG = Array("aa", "bb", "cc")
If RENK = DEG(SAY) Then
RENK.Interior.ColorIndex = 3
End If
Next
Next
End Sub

 

[ozgurpeh]

Sub BICIMLE()
For Each RENK In Range("A1:A60")
RENK.Interior.ColorIndex = xlNone
For SAY = 0 To 2
DEG = Array("aa", "bb", "cc")
If RENK = DEG(SAY) Then
RENK.Interior.ColorIndex = 3
End If
Next
Next
End Sub

hücre rengi değil metin renki kırmızı olucak ayrıca çalıştır komutu ile değil değer girilince kırmızya dönüşsün

 

[N.Ziya Hiçdurmaz]

Yanıt

Sayfa kod kısmına yapıştırınız.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
For Each RENK In Range("A1:A60")
RENK.Font.ColorIndex = 0
For SAY = 0 To 2
DEG = Array("aa", "bb", "cc")
If RENK = DEG(SAY) Then
RENK.Font.ColorIndex = 3
End If
Next
Next
End Sub

 

[baydeniro]

Sayın V.Basic For Applications, paylaşım için teşekkürler.

 

[ozgurpeh]

Sayın V.Basic For Applications, paylaşım için teşekkürler.

Paylaşım için teşekkürler

 

[N.Ziya Hiçdurmaz]

Bişey değil.

 

[ozgurpeh]

Bişey değil.

YA HERŞEY GÜZEL ÇALIŞIYO FAKAT 3 DEN FAZLA DEĞER ALMIYOR

 

[N.Ziya Hiçdurmaz]

Buradan ayarlayabilirsiniz.
For SAY = 0 To 7
DEG = Array("aa", "bb", "cc", "dd", "ee", "ff", "gg", "hh")

 

[ozgurpeh]

Buradan ayarlayabilirsiniz.
For SAY = 0 To 7
DEG = Array("aa", "bb", "cc", "dd", "ee", "ff", "gg", "hh")

ok çok sağol tekrar

 

[Necdet]

İstenilen sözcüklerin renklendirilmesi

Merhaba,

Alternatif olsun, anca fırsat buldum ve ekleyebildim.

Sub BulVeRenklendir()
Dim Durum As Integer
[B1:B50].ClearContents
For i = 2 To [A65536].End(3).Row
    For j = 2 To [D65536].End(3).Row
        Durum = InStr(1, Cells(i, "A"), Cells(j, "D"), vbTextCompare)
        If Durum > 0 Then
            Uz = Len(Cells(j, "D"))
            With Cells(i, "A").Characters(Durum, Uz).Font
                .Size = 12          'Font Büyüklüğü
                .Bold = True        'Koyu istenbiyorsa False yapılmalı
                .Italic = True      'İtalik istenmiyorsa False yapılmayı
                .Underline = False  'Altçizgi istenmiyorsa False yapılmalı
                .ColorIndex = [C2]  'C2 Hücresindeki Renk Kodunu Belirtir
            End With
           Exit For
        End If
    Next j
Next i
End Sub

Sayfada otomatik değişim için aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayınız

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Durum As Integer
On Error GoTo Son
If Intersect(Target, [A2:A62]) Is Nothing Then Exit Sub
    For j = 2 To [D65536].End(3).Row
        Durum = InStr(1, Target, Cells(j, "D"), vbTextCompare)
        If Durum > 0 Then
            Uz = Len(Cells(j, "D"))
            With Target.Characters(Durum, Uz).Font
                .Size = 12          'Font Büyüklüğü
                .Bold = True        'Koyu istenbiyorsa False yapılmalı
                .Italic = True      'İtalik istenmiyorsa False yapılmayı
                .Underline = False  'Altçizgi istenmiyorsa False yapılmalı
                .ColorIndex = [C2]  'C2 Hücresindeki Renk Kodunu Belirtir
            End With
           Exit For
        End If
    Next j
Son:
End Sub

 

[ozgurpeh]

Merhaba,

Alternatif olsun, anca fırsat buldum ve ekleyebildim.

Sub BulVeRenklendir()
Dim Durum As Integer
[B1:B50].ClearContents
For i = 2 To [A65536].End(3).Row
    For j = 2 To [D65536].End(3).Row
        Durum = InStr(1, Cells(i, "A"), Cells(j, "D"), vbTextCompare)
        If Durum > 0 Then
            Uz = Len(Cells(j, "D"))
            With Cells(i, "A").Characters(Durum, Uz).Font
                .Size = 12          'Font Büyüklüğü
                .Bold = True        'Koyu istenbiyorsa False yapılmalı
                .Italic = True      'İtalik istenmiyorsa False yapılmayı
                .Underline = False  'Altçizgi istenmiyorsa False yapılmalı
                .ColorIndex = [C2]  'C2 Hücresindeki Renk Kodunu Belirtir
            End With
           Exit For
        End If
    Next j
Next i
End Sub

Sayfada otomatik değişim için aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayınız

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Durum As Integer
On Error GoTo Son
If Intersect(Target, [A2:A62]) Is Nothing Then Exit Sub
    For j = 2 To [D65536].End(3).Row
        Durum = InStr(1, Target, Cells(j, "D"), vbTextCompare)
        If Durum > 0 Then
            Uz = Len(Cells(j, "D"))
            With Target.Characters(Durum, Uz).Font
                .Size = 12          'Font Büyüklüğü
                .Bold = True        'Koyu istenbiyorsa False yapılmalı
                .Italic = True      'İtalik istenmiyorsa False yapılmayı
                .Underline = False  'Altçizgi istenmiyorsa False yapılmalı
                .ColorIndex = [C2]  'C2 Hücresindeki Renk Kodunu Belirtir
            End With
           Exit For
        End If
    Next j
Son:
End Sub

Paylaşım için teşekürler