Metin içindeki rakamı renklendirme

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
201
Excel Vers. ve Dili
2016 türkçe
Deneyiniz.

C++:
Sub Renklendir()
    Range("B:B").Font.ColorIndex = 0
    Range("B:B").Font.Bold = False
    Range("B:B").Font.Size = 11
    
    For X = 2 To Cells(Rows.Count, 2).End(3).Row
        If Cells(X, 1) = "" Then
            Cells(X, 2).Font.Bold = True
        Else
            Data = Split(Cells(X, 2), " ")
            Ilk = 0
            For Y = 0 To UBound(Data)
                If IsNumeric(Data(Y)) Then
                    Cells(X, 2).Characters(Ilk, Len(Data(Y)) + 4).Font.ColorIndex = 3
                    Cells(X, 2).Characters(Ilk, Len(Data(Y)) + 4).Font.Bold = True
                    Cells(X, 2).Characters(Ilk, Len(Data(Y)) + 4).Font.Size = 11
                    Ilk = Ilk + Len(Data(Y)) + 1
                Else
                    Ilk = Ilk + Len(Data(Y)) + 1
                End If
            Next
        End If
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Teşekkür oldu istediğim ama olan makronun içine nasıl entegre edebilirim acaba ?
 

Murat OSMA

Altın Üye
Altın Üye
Katılım
23 Mayıs 2011
Mesajlar
5,500
Excel Vers. ve Dili
Microsoft 365 TR-EN
RegExp ile alternatif;
C#:
Sub Emre()
    Set Osma = CreateObject("vbscript.regexp")
    Osma.Global = True
    Osma.Pattern = "[^A-Z]+TL"
    For Each veri In Range("B:B").SpecialCells(2, 2)
        Set ara = Osma.Execute(veri.Text)
        If Not ara Is Nothing Then
            For Each i In ara
                veri.Characters(i.FirstIndex + 1, i.Length).Font.Color = vbRed
            Next i
        End If
    Next veri
End Sub
 

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
201
Excel Vers. ve Dili
2016 türkçe
RegExp ile alternatif;
C#:
Sub Emre()
    Set Osma = CreateObject("vbscript.regexp")
    Osma.Global = True
    Osma.Pattern = "[^A-Z]+TL"
    For Each veri In Range("B:B").SpecialCells(2, 2)
        Set ara = Osma.Execute(veri.Text)
        If Not ara Is Nothing Then
            For Each i In ara
                veri.Characters(i.FirstIndex + 1, i.Length).Font.Color = vbRed
            Next i
        End If
    Next veri
End Sub
Merhaba teşekkürler kırmızı olan yerler kalın olursa çok güzel olur bide son olarak analiz makrosunun içine nasıl entegre edebilirim acaba bunu ?
 

Murat OSMA

Altın Üye
Altın Üye
Katılım
23 Mayıs 2011
Mesajlar
5,500
Excel Vers. ve Dili
Microsoft 365 TR-EN
Rengin altına bu satırı ekleyin..
C#:
veri.Characters(i.FirstIndex + 1, i.Length).Font.Bold = True
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, Veri As Range, S2 As Worksheet, Metin As Variant, Ilk As Integer
    Dim Son As Long, X As Long, Y As Integer, Satir As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("BORÇ LİSTESİ")
    
    S1.Range("A:B").Clear
    Son = S1.Cells(S1.Rows.Count, "H").End(3).Row
    
    For Each Veri In S1.Range("H2:H" & Son)
        If Veri.Value <> "" Then
            Set S2 = Sheets(CStr(Veri.Value))
            Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
            S1.Cells(Satir, 2) = Veri.Value
            S1.Cells(Satir, 2).Font.ColorIndex = Veri.Font.ColorIndex
            S1.Cells(Satir, 2).Font.Bold = True
            S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
            
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row - 1
                        
            For X = 4 To Son
                If S2.Cells(X, "Q") > 0 Then
                    Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    S1.Cells(Satir, 1) = S2.Cells(X, "C")
                    S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
                    S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
                    
                    Metin = Split(S1.Cells(Satir, 2), " ")
                    Ilk = 0
                    
                    For Y = 0 To UBound(Metin)
                        If IsNumeric(Metin(Y)) Then
                            S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.ColorIndex = 3
                            S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Bold = True
                            S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Size = 11
                            Ilk = Ilk + Len(Metin(Y)) + 1
                        Else
                            Ilk = Ilk + Len(Metin(Y)) + 1
                        End If
                    Next
                End If
            Next
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
201
Excel Vers. ve Dili
2016 türkçe
Deneyiniz.

C++:
Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, Veri As Range, S2 As Worksheet, Metin As Variant, Ilk As Integer
    Dim Son As Long, X As Long, Y As Integer, Satir As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("BORÇ LİSTESİ")
   
    S1.Range("A:B").Clear
    Son = S1.Cells(S1.Rows.Count, "H").End(3).Row
   
    For Each Veri In S1.Range("H2:H" & Son)
        If Veri.Value <> "" Then
            Set S2 = Sheets(CStr(Veri.Value))
            Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
            S1.Cells(Satir, 2) = Veri.Value
            S1.Cells(Satir, 2).Font.ColorIndex = Veri.Font.ColorIndex
            S1.Cells(Satir, 2).Font.Bold = True
            S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
           
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row - 1
                       
            For X = 4 To Son
                If S2.Cells(X, "Q") > 0 Then
                    Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    S1.Cells(Satir, 1) = S2.Cells(X, "C")
                    S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
                    S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
                   
                    Metin = Split(S1.Cells(X, 2), " ")
                    Ilk = 0
                   
                    For Y = 0 To UBound(Metin)
                        If IsNumeric(Metin(Y)) Then
                            Cells(X, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.ColorIndex = 3
                            Cells(X, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Bold = True
                            Cells(X, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Size = 11
                            Ilk = Ilk + Len(Metin(Y)) + 1
                        Else
                            Ilk = Ilk + Len(Metin(Y)) + 1
                        End If
                    Next
                End If
            Next
        End If
    Next
   
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
üstler olmuş teşekkürler ama 104. satırdan sonrası siyah olarak kalmış...
 
Üst