Metin içindeki tarihi renklendirme

[Feylosof]

İyi geceler diliyorum.
Bir hücrede bir kaç cümlelik metin içinde gömülü olan herhangi bir tarihi nasıl renklendirebiliriz? vba olarak kodu nasıl yazmalıyız yardımcı olur musunuz?

 

[Korhan Ayhan]

Forumda characters ifadesi ile arama yapınız. Bu konuyla ilgili örnekler var.

 

[Feylosof]

Tamam @Korhan Ayhan üstadım. Yol gösterici yaklaşımınız için çok teşekkür ederim.

 

[Feylosof]

Malesef benim kod bilgim onca örnek içinde tarih cinsinden olan yazıyı renklendirecek şekilde düzenleme yapmaya yetmemektedir.

 

[ÖmerFaruk]

Cümleleriniz standart olup sadece tarihler mi farklı?
Cümlelerinizden (gizlilik gerektimeyecek şekilde) bir kaçını buraya yazarmısınız?

 

[Feylosof]

@ÖmerFaruk üstadım cümleler standart fakat tarihler dosyanın hazırlandığı döneme göre değişmektedir.
Örneğin A11 HÜCRESİNE

Aşağıda durumu belirtilen okulumuz öğretmen ve yöneticilerine 16/12/2006 tarih ve 26378 sayılı Resmi Gazetede Yayımlanan 2006/11350 sayılı Milli Eğitim Bakanlığı Öğretmen ve Yöneticilerinin ders ücretlerine ilişkin esasları hakkındaki kararları hükümleri gereğince 06.09.2021 tarihinden itibaren görev olarak verilecek dersleri okutmalarını ve her saat için ek ders ücret göstergesi ile memur maaş katsayısına göre hesaplanarak ek ders ücretlerinin ödenmesini olurlarınıza arz ederim.

 

[Feylosof]

Bunun muadili bir cümle de A19 hücresinde bulunmaktadır

 

[ÖmerFaruk]

Tarihlerinizin formatını aynı yapma şansınız var mı?
Mesela gg.aa.yyyy gibi

 

[Feylosof]

Tabi ki bu mümkündür. bir sorun teşkil etmez

 

[Feylosof]

@ÖmerFaruk bey tarihlerden 01/01/2021 formatta olanı bırakıp 01.01.2021 formatında olanı renklendirse bu olabilir mi?. Böyle olursa benim değişiklik yaptığım tarihleri renklendirmiş değişiklik yapmayacağım tarihleri es geçmiş olur ki bu şekilde takibini yapmamı kolaylaştırmış olur.

 

[ÖmerFaruk]

Ben denemek için D2 hücresini kullandım. Kodların ilk satrındaki D2 kısmı için açıklama yazdım

Sub TarihRenklendir()
Dim Bak As Range, i As Integer, Dizi, StartPoz As Integer, Uzunluk As Integer
    Set Bak = Range("D2") 'Arzu ederseniz bu kısımda A1 yerine başka hücreyi refere edebilir ya da döngü içinde kullanabilirsiniz.
    Dizi = Split(Bak, " ")
    For i = 0 To UBound(Dizi) - 1
        If Len(Dizi(i)) - Len(Replace(Dizi(i), ".", "")) = 2 Then
        StartPoz = InStr(1, Bak, Dizi(i))
        Uzunluk = Len(Dizi(i))
        GoTo Jmp1
        End If
    Next i
    Exit Sub
Jmp1:
    Bak.Font.Bold = False
    Bak.Font.Color = vbBlack
    Bak.Characters(Start:=StartPoz, Length:=Uzunluk).Font.Bold = True
    Bak.Characters(Start:=StartPoz, Length:=Uzunluk).Font.Color = vbRed
End Sub

 

[Zeki Gürsoy]

Klasik Regular Expressions ile bir çözüm...

Public Sub Test()
    SetDateColor [a11]
End Sub

Private Sub SetDateColor(rng As Range)
    Static reg As Object, mc As Object, m As Object
   
    If reg Is Nothing Then Set reg = CreateObject("VBScript.RegExp")
   
    reg.Global = True
    reg.MultiLine = True
    reg.Pattern = "(?:0?[1-9]|[1-2][0-9]|3[0-1])\.(?:0?[1-9]|1[0-2])\.(?:19\d{2}|20\d{2}|0[0-9]|[1-9][0-9])"
   
    If reg.Test(rng) = False Then Exit Sub
   
    Set mc = reg.Execute(rng)
   
    For Each m In mc
        rng.Characters(m.FirstIndex + 1, m.length).Font.Color = vbRed
    Next
   
End Sub

 

[Feylosof]

@ÖmerFaruk Üstadım oldu. Çok teşekkür ederim. Hatta böyle daha iyi oldu. Emeğinize sağlık. Varolun.

 

[Feylosof]

Klasik Regular Expressions ile bir çözüm...

Public Sub Test()
    SetDateColor [a11]
End Sub

Private Sub SetDateColor(rng As Range)
    Static reg As Object, mc As Object, m As Object
  
    If reg Is Nothing Then Set reg = CreateObject("VBScript.RegExp")
  
    reg.Global = True
    reg.MultiLine = True
    reg.Pattern = "(?:0?[1-9]|[1-2][0-9]|3[0-1])\.(?:0?[1-9]|1[0-2])\.(?:19\d{2}|20\d{2}|0[0-9]|[1-9][0-9])"
  
    If reg.Test(rng) = False Then Exit Sub
  
    Set mc = reg.Execute(rng)
  
    For Each m In mc
        rng.Characters(m.FirstIndex + 1, m.length).Font.Color = vbRed
    Next
  
End Sub

Hocam emeğiniz için teşekkürler. Bu vesile ile bir kaynağa sahip olmuş olduk

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Color_The_Date_In_The_Text()
    Dim X As Long, Y As Long
    
    With Range("A1")
        .Font.Color = False
        .Font.Bold = False
        For X = 1 To Len(.Value)
            On Error Resume Next
            Y = WorksheetFunction.Search("??.??.????", .Value, IIf(Y = 0, 1, Y + 1))
            If Err.Number = 0 Then
                .Characters(Y, 10).Font.Color = vbRed
                .Characters(Y, 10).Font.Bold = True
            Else
                Err.Clear
                GoTo 10
            End If
        Next
    End With

10  MsgBox "Your transaction is complete.", vbInformation
End Sub

 

[assenucler]

Sayın feylosof,

Açtığınız konu ilgimi çekti. Dosyanızın çok kısa da olsa, bir küçük örneğini eklemeniz mümkün mü?

İlgi ve yardımınız için teşekkür ederim.