Kelime Öbeği Renklendirme

[leonadies]

Merhaba p Sütununda çeşitli verilerim var. Bu sütunda ünlem işareti olan yerden itibaren kelimelerin renklenmesini istiyorum.. Örneğin;

P36 Ali veli ayşe !turgut
P97 hikmet selçuk !handan
p1025 kaya adem ilyas osman !eda

şeklinde yani ben hücreye ! eklediğim yerden itibarentüm kelimeler kendi kendi kendine renklensin. Yani isteğim koşulludaki gibi tüm hücre renklenmesi değil kelime öbeği renklenmesi şeklinde

 

[Muzaffer Ali]

Sayfanın kod editörüne aşağıdaki kodu kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sira As Long
    Dim Obek As Long
    Sira = WorksheetFunction.Find("!", Target.Text)
    Obek = Len(Target.Text) - Sira + 1
    Target.Characters(Start:=Sira, Length:=Obek).Font.Color = -16776961
End Sub

 

[leonadies]

Sayfanın kod editörüne aşağıdaki kodu kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sira As Long
    Dim Obek As Long
    Sira = WorksheetFunction.Find("!", Target.Text)
    Obek = Len(Target.Text) - Sira + 1
    Target.Characters(Start:=Sira, Length:=Obek).Font.Color = -16776961
End Sub

Tesekkur ederim. Kod tum sayfa için calisiyor. Sadece p sutunu icin nasil bi yol izlemeliyiz?

 

[Muzaffer Ali]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sira As Long
    Dim Obek As Long
    If Intersect(Target, Range("P:P")) Is Nothing Then Exit Sub
    On Error Resume Next
    Sira = WorksheetFunction.Find("!", Target.Text)
    Obek = Len(Target.Text) - Sira + 1
    Target.Characters(Start:=Sira, Length:=Obek).Font.Color = -16776961
End Sub

 

[leonadies]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sira As Long
    Dim Obek As Long
    If Intersect(Target, Range("P:P")) Is Nothing Then Exit Sub
    On Error Resume Next
    Sira = WorksheetFunction.Find("!", Target.Text)
    Obek = Len(Target.Text) - Sira + 1
    Target.Characters(Start:=Sira, Length:=Obek).Font.Color = -16776961
End Sub

Simdide ne yazarsam yazayim p sutunu kelimeleri renkleniyor. Unleme bakmadan yani

 

[Muzaffer Ali]

Şimdi oldu

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sira As Long
    Dim Obek As Long
    If Intersect(Target, Range("P:P")) Is Nothing Then Exit Sub
    On Error GoTo 1
    Sira = WorksheetFunction.Find("!", Target.Text)
    Obek = Len(Target.Text) - Sira + 1
    Target.Characters(Start:=Sira, Length:=Obek).Font.Color = -16776961
1:
End Sub

 

[leonadies]

Şimdi oldu

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sira As Long
    Dim Obek As Long
    If Intersect(Target, Range("P:P")) Is Nothing Then Exit Sub
    On Error GoTo 1
    Sira = WorksheetFunction.Find("!", Target.Text)
    Obek = Len(Target.Text) - Sira + 1
    Target.Characters(Start:=Sira, Length:=Obek).Font.Color = -16776961
1:
End Sub

Malesef olmadı hatta bazen farklı sütunlarıda renklendiriyor ve asla ünleme bakmıyor. Dosya Ekliyorum

 

[Muzaffer Ali]

Ekte gönderdiğiniz dosyayı inceledim aynen sizin istediğiniz şekilde çalışıyor. Bir sıkıntı yok.

 

[leonadies]

Ekte gönderdiğiniz dosyayı inceledim aynen sizin istediğiniz şekilde çalışıyor. Bir sıkıntı yok.

Üstadim defalarca denedim p sutununda rastgele yerlerde denemeler yapiyorum ancak sonuc ayni unleme bakmadan ilk yazdigim andan itibaren kirmizi yaziyo. Bazen siyaha da dönüyo. Daha fazla deneme yapabilirsiniz. Webddebaya aradim
Bir çok kisiye faydasi olacaktir dusuncesindeyim

 

[Muzaffer Ali]

Şimdi tekrar defalarca denedim P sütununda çalışıyor diğer hiçbir hücrede çalışmıyor.

 

[netkit]

Ofis 2016 da da sadece p de renklendirdi.

 

[askm]

if Intersect(Target, Range("P")) Is Nothing Then Exit Sub satırından dolayı sadece p sütununda çalışır.

 

[netkit]

Evet Sayın ASKM;
Kod doğru çalışıyor manasında yazdım ama ifade eksik kalmış herhalde

if Intersect(Target, Range("P")) Is Nothing Then Exit Sub satırından dolayı sadece p sütununda çalışır.