hücre içinde yazı ve rakam kontrolü

[vivident]

Merhaba

Ekteki listede A sütunundaki veri ile C sütunundaki veriyi kıyaslama yapıyorum. Birbirlerine eşit mi diye. Eşit olmayan hücrelere ait satır, sarı renk font ile boyanıyor

Lakin ben eşit olmamasına neden olan değerin (rakam veya metnin) yazı tipi rengini de kırmızı ile boyanmasını istiyorum ki göze çarpsın

Sitede aradım ama buna benzer örnek bulamadım


BILGILER
[ ] köşeli parantez içindeki rakamlar
TRUE, FALSE metinleri
benim değişken değerlerim

Aşağıda karşılaştırma yaptığım karakterlerden bir örnek var

:= [FALSE,TRUE,TRUE ,[500,500,5000,1000],[TRUE,0,0,0,0,0,0],"pBeforePickT1S1",[FALSE,"","","","","","",0,0,0,""]];

 

[askm]

Aşağıdaki kodu deneyin.

Sub ASKM_Hücre_Icı_Boya()
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone
Cells.Font.ColorIndex = xlAutomatic
Dim i As Integer
For i = 1 To 100
başlangıc = 0
    If Sheets("deneme").Cells(i, 1).Value <> Sheets("deneme").Cells(i, 3).Value Then
    Range("A" & i & ":C" & i).Interior.ColorIndex = 6
        Kelime1 = Split(Range("A" & i), ",")
        Kelime2 = Split(Range("C" & i), ",")
            For x = 0 To UBound(Kelime1)
            
            başlangıc = başlangıc + Len(Kelime1(x))
                If Kelime1(x) <> Kelime2(x) Then
                    Uzunluk = Len(Kelime1(x))
                    Cells(i, 1).Characters(Start:=başlangıc - 2, Length:=Uzunluk).Font.Color = vbRed
                End If
            Next x
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Farklı Kelime ve hücreler renklendirildi...", vbInformation, "ASKM"
End Sub

 

[Ömer BARAN]

Merhaba.

Alternatif olsun.
.

[B][COLOR="blue"]Sub Karar()[/COLOR][/B]
Dim i As Integer
Cells.Interior.ColorIndex = xlNone: Cells.Font.Color = vbBlack
[C:C].Font.Bold = False: [C:C].Font.Size = 8
For i = 1 To Cells(Rows.Count, 1).End(3).Row
    If Sheets("deneme").Cells(i, 1).Value <> Sheets("deneme").Cells(i, 3).Value Then
    Range("A" & i & ":C" & i).Interior.ColorIndex = 6
        For k = 1 To Len(Cells(i, 3))
            If Mid(Cells(i, 1), k, 1) <> Mid(Cells(i, 3), k, 1) Then
                For kk = 1 To Len(Mid(Cells(i, 3), k, 255))
                    If Right(Cells(i, 1), kk) <> Right(Cells(i, 3), kk) Then
                    Exit For: End If
                Next: Exit For: End If: Next[B][COLOR="Red"][SIZE="4"]: fark = 0[/SIZE]
    If Mid(Cells(i, 3), kk + 1, 1) <> "]" Or Mid(Cells(i, 3), kk + 1, 1) <> "," Then fark = 1[/COLOR][/B]
    With Cells(i, 3).Characters(Start:=k, Length:=Len(Mid(Cells(i, 3), k, 255)) - kk + 1[B][COLOR="red"][SIZE="4"] + fark[/SIZE][/COLOR][/B])
        .Font.FontStyle = "Kalın": .Font.Size = 10: .Font.Color = vbRed
    End With: End If
Next i
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B][COLOR="Blue"]End Sub[/COLOR][/B]

 

[vivident]

Sayın askm ve Sayın Ömer Baran
Verdiğiniz kodları, ana dosyamda yaklaşık 944 adet satır olan dosyamda denediğimde farklı durumlar ortaya çıktı

Örneğin metinlerde [false, true]
FALSE gibi bir durum var. Ben "FALSE" kelimesinin hepsinin kırmızı yanmasını istiyorum

Örneğin rakamlarda [ , , ]
Parantez içindeki "," virgüle gelinceye kadar olan tam sayıyı karşılaştırmasını istiyorum. Sanıyorum ki verdiğiniz kodlarda rakam kıyaslıyor
Örneğin istediğim
[12.23,100.02,51.25] ------- [12.23,105.11,51.25]

Ben direk ana dosyamı paylaşıyorum.

 

[vivident]

Konu Günceldir

 

[Ömer BARAN]

Tekrar merhaba.
Benim verdiğim kod;
-- önce soldan başlayarak tek tek tüm karakterlerin aynı olup olmadığını kontrol ediyor,
-- farklılığa rastladığında, bu kez sağdan tek tek karakterlerin aynı olup olmadığını kontrol ediyor,
-- soldan farklı karakterin konumu ile sağdan farklı karakterin konumu arasını renklendiriyor.

Neticede;
-- ya Sayın askm'nin, verdiği kod'da güncelleme yapmasını bekleyeceksiniz,
(bence kendisi, bu işlem için daha isabetli olan kelime-kelime kontrol yöntemini uygulamış),
-- ya da benim önceki kod cevabımda güncellediğim kod'un yeni halini (ilave olan kısımları kırmızı renklendirdim) tekrar deneyeceksiniz.
.

 

[askm]

Sub ASKM_Hücre_Icı_Boya()
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone
Cells.Font.ColorIndex = xlAutomatic
Dim i As Integer
Dim SonSat As Long
SonSat = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To SonSat
başlangıc = 0
    If Sheets("=").Cells(i, 1).Value <> Sheets("=").Cells(i, 3).Value Then
    Range("A" & i & ":C" & i).Interior.ColorIndex = 6
    say = say + 1
    
            Kelime1 = Split(Range("A" & i), ",")
            Kelime2 = Split(Range("C" & i), ",")
            For x = 0 To UBound(Kelime1)
                If x > 0 Then
                    başlangıc = başlangıc + Len(Kelime1(x - 1)) + 1
                Else
                    başlangıc = 0
                End If
                If Kelime1(x) <> Kelime2(x) Then
                    Uzunluk = Len(Kelime1(x))
                    Cells(i, 1).Characters(Start:=başlangıc + 1, Length:=Uzunluk).Font.Color = vbRed
                End If
            Next x
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Farklı Kelime ve hücreler renklendirildi...", vbInformation, "ASKM"
End Sub

 

[antonio]

Alternatif olsun:

Sub uymayan_verileri_renklendir()
Dim sh As Worksheet, ss As Long, yer As Integer, tamyer As Integer, uzunluk As Byte
Set sh = Sheets("deneme")
ss = sh.Range("A55500").End(3).Row

For i = 1 To ss

veri1 = Split(Trim(sh.Range("A" & i).Value), ",")
veri2 = Split(Trim(sh.Range("C" & i).Value), ",")

For d = 0 To UBound(veri1)
  If veri1(d) <> veri2(d) Then
    With sh.Range("C" & i)

        Select Case d
            Case Is = 0
                yer = InStr(1, .Value, veri2(0))
            Case Else
                yer = InStr(Len(veri2(d - 1)), .Value, veri2(d))
        End Select

        uzunluk = Len(veri2(d))
        .Characters(yer, uzunluk).Font.ColorIndex = 3
    End With
  End If
Next d
Next i
MsgBox "İşlem tamamlandı.", vbInformation, "antonio"
End Sub

 

[vivident]

sayın askm, sayın antonio, sayın ömer baran
hepinize çok teşekkür ediyorum