Metin İçerisinde Renk atama

[Porser]

İyi günler

A1 hücresinde : AHFR9023IOKK yazmakta
Koşullu biçimlendirme ile hücre rengi kritere göre renkleniyor tamam bunda sorun yok
A1 Hücresine AHFR9023IOKK yazıldığında otomatik sadece hücre içerisindeki rakamlar renklenebilirmi ?
Örnek : AHFR9023IOKK

 

[YUSUF44]

Aşağıdaki makro A sütunundaki hücrelerde istediğiniz işlemi yapar:

Sub renkle()
Dim RegExp As Object
Set RegExp = CreateObject("VBScript.Regexp")

RegExp.Pattern = "[^0-9]"
RegExp.Global = True

son = Cells(Rows.Count, "A").End(3).Row
For i = 1 To son
    For j = 1 To Len(Cells(i, "A"))
        If RegExp.Replace(Mid(Cells(i, "A"), j, 1), "") <> "" Then
            Cells(i, "A").Characters(Start:=j, Length:=1).Font.Color = vbRed
            Cells(i, "A").Characters(Start:=j, Length:=1).Font.Bold = True
        Else
            Cells(i, "A").Characters(Start:=j, Length:=1).Font.Color = vbBlack
            Cells(i, "A").Characters(Start:=j, Length:=1).Font.Bold = False
        End If
    Next
Next
End Sub

 

[Haluk]

VBA ile yapılabilir....

Bunun için, aşağıdaki kodu sayfa modülüne ekleyip deneyebilirsiniz...

Private Sub Worksheet_Change(ByVal Target As Range)
'   Haluk - 21/09/2020
    Dim myStr As String, regExp As Object, objMatches As Object, xMatch As Object
    
    If Not Intersect(Range("A2:A" & Rows.Count), Target) Is Nothing Then
        myStr = Target.Text
        
        Set regExp = CreateObject("VBscript.RegExp")
        
        regExp.Pattern = "(\d+)"
        regExp.Global = True
        
        Set objMatches = regExp.Execute(myStr)
        
        For Each xMatch In objMatches
            Target.Characters(xMatch.firstindex + 1, xMatch.Length).Font.Bold = True
            Target.Characters(xMatch.firstindex + 1, xMatch.Length).Font.Color = vbRed
        Next
    End If
    
    Set objMatches = Nothing
    Set regExp = Nothing
End Sub

Not: A1 hücresinde sütun başlığı olduğu varsayıldığından, kod A2 hücresi ve altındaki hücrelerde çalışır....


.

 

[bmutlu966]

Alternetif olsun.

Sub renklendir()

son = [A65000].End(3).Row
For s = 1 To son
    For t = 1 To Len(Cells(s, "A"))
        x = Mid(Cells(1, "A"), t, 1)
        If IsNumeric(x) Then
            Cells(s, "A").Characters(Start:=t, Length:=1).Font.Color = RGB(255, 0, 0)
        End If
    Next
Next
End Sub

 

[bmutlu966]

Üstteki kodda hata yapmışım

Sub renklendir()

son = [A65000].End(3).Row
For s = 1 To son
    For t = 1 To Len(Cells(s, "A"))
        x = Mid(Cells(s, "A"), t, 1)
        If IsNumeric(x) Then
            Cells(s, "A").Characters(Start:=t, Length:=1).Font.Color = RGB(255, 0, 0)
        End If
    Next
Next
End Sub

 

[Porser]

Hepinize Çok teşekkür ederim. İşimi gördüm
Bunun makrosuz hali sanırım imkansız