Cümle içinde T.C. renklendirme

[ASLAN7410]

Merhaba, hayırlı günler.

Ekte gönderdiğim excel dosyamın 1.sayfasında D2 sütunundan aşağıya doğru verilerim mevcut, veriler arasında 11 rakam olan T.C. lerin göze çarpması için buton bastığımda kalın kırmızı renklenmesini istiyorum.
Yardımcı olur musunuz?

 

[ASLAN7410]

Bu işlem, koşullu biçimlendirme ile oluyorsa da olabilir.

 

[YUSUF44]

Aşağıdaki makroyla yapabilirsiniz:

Sub tcnobelirt()
son = Cells(Rows.Count, "D").End(3).Row
For i = 2 To son
    For j = 1 To Len(Cells(i, "D"))
        If Mid(Cells(i, "D"), j, 1) = "1" Or Mid(Cells(i, "D"), j, 1) = "2" Or Mid(Cells(i, "D"), j, 1) = "3" Or _
            Mid(Cells(i, "D"), j, 1) = "4" Or Mid(Cells(i, "D"), j, 1) = "5" Or Mid(Cells(i, "D"), j, 1) = "6" Or _
            Mid(Cells(i, "D"), j, 1) = "7" Or Mid(Cells(i, "D"), j, 1) = "8" Or Mid(Cells(i, "D"), j, 1) = "9" Or _
            Mid(Cells(i, "D"), j, 1) = "0" Then
            Cells(i, "D").Characters(Start:=j, Length:=11).Font.Bold = True
            Cells(i, "D").Characters(Start:=j, Length:=11).Font.Color = vbRed
            j = Len(Cells(i, "D"))
        End If
    Next
Next
End Sub

Aşağıdaki makro da bu değişikliği iptal eder:

Sub iptal()
    son = Cells(Rows.Count, "D").End(3).Row
    Range("D2:D" & son).Font.Bold = False
    Range("D2:D" & son).Font.Color = vbBlack
End Sub

 

[ASLAN7410]

Sayın Yusuf Bey, ellerinize sağlık çok güzel çalıyor, ama küçük bir sorun var.
Hücre içindeki rakamların hepsi renkleniyor. Örneğin hücre içinde 06ABCD06 gibi plaka varsada buda renkleniyor.
Sadece 11 rakam olanlar renklense süper olacak.

 

[EmrExcel16]

Alternatif olarak..

Sub TC_No_Renklendir()
    Dim x, y, tc, veri
    On Error Resume Next
    Application.ScreenUpdating = False
    For x = 2 To Cells(Rows.Count, 4).End(3).Row
        For y = 1 To Len(Cells(x, 4))
            If Len(veri) <> 11 Then
                If Mid(Cells(x, 4), y, 1) Like "[0-9]" Then
                    veri = veri & Mid(Cells(x, 4), y, 1)
                Else
                    veri = Empty
                End If
            End If
        Next
        If Len(veri) = 11 Then
            tc = WorksheetFunction.Find(Trim(veri), Cells(x, 4))
            Cells(x, 4).Characters(tc, 11).Font.Bold = True
            Cells(x, 4).Characters(tc, 11).Font.Color = vbRed
        End If
        veri = Empty
    Next
    Application.ScreenUpdating = True
End Sub

 

[Necdet]

Merhaba,

Alternatif olsun. Haluk Bey'in kodlarının revizesidir.

 Sub TC_Renklendir()
    'Haluk - 08/11/2019

 
    Dim TC  As String, _
        i   As Long, _
        j   As Integer
        
    Set regExp = CreateObject("VBScript.RegExp")
  
    regExp.IgnoreCase = True
    regExp.Global = True
    regExp.Pattern = "(\d{11})"
        
    Application.ScreenUpdating = False
    
    For i = 2 To Cells(Rows.Count, "D").End(3).Row
    
        If regExp.Test(Cells(i, "D").Text) Then
            Set objMatches = regExp.Execute(Cells(i, "D"))
            TC = objMatches.Item(0).Submatches.Item(0)
            j = InStr(Cells(i, "D"), TC)
            With Range("D" & i).Characters(j, 11).Font
                .Bold = True
                .Color = vbBlue
            End With
        Else
            GetTC = "Tarih YOK!"
        End If
    Next i

    Set regExp = Nothing
    Application.ScreenUpdating = True
    
End Sub

 

[ASLAN7410]

Sayın Emre Bey, bilgisayarın başına yeni geçtim, ilginiz için çok teşekkür ederim, yazmış olduğunuz kodlar, hücrede sadece 123 rakamı olsa dahi renklendiriyor.

 

[ASLAN7410]

Sayın Necdet Bey, ellerinize sağlık çok teşekkür ediyorum, tam istediğim gibi çalışıyor.
Hayırlı günler diliyorum.

 

[EmrExcel16]

Sayın Emre Bey, bilgisayarın başına yeni geçtim, ilginiz için çok teşekkür ederim, yazmış olduğunuz kodlar, hücrede sadece 123 rakamı olsa dahi renklendiriyor.

#5 nolu mesajımdaki kodları bu doğrultuda tekrardan güncelledim.

 

[ASLAN7410]

Sayın Emre Bey, ellerinize sağlık çok teşekkür ediyorum, şimdi oldu tam istediğim gibi çalışıyor.
Hayırlı günler diliyorum.

 

[EmrExcel16]

Sayın Emre Bey, ellerinize sağlık çok teşekkür ediyorum, şimdi oldu tam istediğim gibi çalışıyor.
Hayırlı günler diliyorum.

Rica ederim , iyi çalışmalar.