Metin içindeki rakamı renklendirme

O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
Korhan Ayhan' Alıntı:
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
Genişletmek için tıkla ...
Teşekkür oldu istediğim ama olan makronun içine nasıl entegre edebilirim acaba ?
 
Murat OSMA

Murat OSMA

Altın Üye
Altın Üye
Katılım
23 Mayıs 2011
Mesajlar
5,508
Excel Vers. ve Dili
Microsoft 365 TR-EN
Altın Üyelik Bitiş Tarihi
31-12-2028
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
 
O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
Murat OSMA' Alıntı:
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
Genişletmek için tıkla ...
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

Murat OSMA

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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
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
 
O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
Korhan Ayhan' Alıntı:
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
Genişletmek için tıkla ...
üstler olmuş teşekkürler ama 104. satırdan sonrası siyah olarak kalmış...
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst