Metin içindeki karakterleri kriterlere göre renklendirme

M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe
Merhabalar;

Kelimeler sayfasının A sütunundaki kelimeler iş listesi sayfasındaki B sütunundaki metin içerisinde teker teker döngüye giriyor ve kelimeler sayfasındaki A sütunundaki kelimeleri içeriyorsa içeren kelimelerin fontu mavi ile renklenecek ve zemin rengi de istediğimiz bir renk ile renklendirilecek ve bir soldaki hücre de (offset( 0,-1) sadece zemin rengi istenilen renk ile renklendirilecek fakat Kelimeler sayfasının B sütunundaki kelimeler iş listesi sayfasındaki B sütunundaki metin içerisinde mevcut ise o kelimeler
renklendirme dışında kalacak

ben bir yere kadar yaptım fakat Kelimeler sayfasının B sütunu için bir işlem oluşturamadım

link

DENEME.xlsb

dosyayı indir, full download - DENEME.xlsb
dosya.org dosya.org

Kod: 
Option Explicit
Sub kelimedeBul()
Dim ws As Worksheet
Dim sh As Worksheet
Dim col As Collection
Dim shrng As Range
Dim shLr, shLr2, wsLr, mbul, shKacinci, wsKacinci As Long
Dim sayac, shUzunluk, tekrar, BaslangicSatir As Long
Dim i, j, k, l As Long
Dim str1, str2, str3 As String


Set ws = Data
Set sh = Kelimeler
Set col = New Collection

shLr = sh.Cells(Rows.Count, "A").End(xlUp).Row
shLr2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
wsLr = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws.Range("A2:B" & wsLr).Interior
    .Pattern = xlNone
End With
With ws.Range("A2:B" & wsLr).Font
    .ColorIndex = xlAutomatic
    .Bold = False
    .FontStyle = "Normal"
    .ColorIndex = xlAutomatic
End With

Set shrng = sh.Range("B2:B" & shLr2)

For i = 2 To wsLr

    For j = 2 To shLr

        On Error Resume Next
        
        'Bu kısmı yapamadım.
        shKacinci = Application.Match("*" & sh.Cells(j, "A") & "*", shrng, 0)
        
        
        
        str1 = UCase(Replace(ws.Cells(i, "B").Value, "i", "İ"))
        str2 = UCase(Replace(sh.Cells(j, "A").Value, "i", "İ"))
        tekrar = (Len(str1) - Len(Application.Substitute(str1, str2, ""))) / Len(str2)

        If IsError(shKacinci) And tekrar > 0 Then
            sayac = 1

            For k = 1 To tekrar

                mbul = Application.Search(str2, str1, sayac)
                sayac = mbul + 1
                shUzunluk = Len(str2)

                ws.Cells(i, "B").Characters(Start:=mbul, Length:=shUzunluk).Font.Color = vbBlue
                ws.Cells(i, "B").Characters(Start:=mbul, Length:=shUzunluk).Font.Bold = True

            Next k

            ws.Range(ws.Cells(i, "A"), ws.Cells(i, "B")).Interior.Color = RGB(184, 204, 228)
            ws.Range(ws.Cells(i, "A"), ws.Cells(i, "B")).Font.Bold = True
            
        End If

        On Error GoTo 0
    Next j

 Next i

Set ws = Nothing
Set sh = Nothing
Set shrng = Nothing
Set col = Nothing

End Sub

Saygılarımla
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
32.satırdaki
yüz Cihazın0 panel kırık binsekizyüzlir yüzünden

ifadesi nasıl renklendirilecek. Onu da manuel yapar mısınız?
 
M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe

Merhabalar


Kod: 
KELİME DAHİL("*" İÇERİRSE) RENKLENDİR
YÜZ
BİN
TL
SEKİZ
LİRA
İKİ
ÜÇ
VS.

KELİME HARİÇ("*" İÇERİRSE) RENKLENDİRME
YÜZÜN
YÜZDEN
KÜÇÜK
GÜÇ
VS.

Kelimeler sayfasındaki Kelime dahil sütununda bulunan kelimeler iş listesi sayfasının B sütunun misal B2 hücresinde içeriyorsa(varsa) o içeren kelimeler veya harf/sayılar vs ... fontu maviye zemin rengi misal yeşil renge boyanacak


Kelimeler sayfasındaki Kelime hariç sütununda bulunan kelimeler iş listesi sayfasının B sütunun misal B2 hücresinde içeriyorsa(varsa) o içeren kelime veya harf/sayılar vs ... fontu hiç bir renge boyanmayacak

Örnek olarak verdiğim
yüz Cihazın0 panel kırık binsekizyüzlir yüzünden ifadesi

yüz Cihazın0 panel kırık binsekizyüzlir yüzünden (font maviye ayrıca zemin rengi de yeşil veya başka bir renkte olabilir) olacak

İş listesi B2 hücresindeki bulunan Yüz, bin, sekiz kelimesi Kelimeler sayfasını A sütunda geçtiği için bunlar maviye renklenecek ve zemin rengi misal yeşil olacak
fakat yüzün, YÜZDEN, KÜÇÜK, GÜÇ VS. ifadeleri Kelimeler sayfasını A sütunda geçerse, içerirse iş listesi B2 hücresindeki yüzün kelimesi fontu boyama yapılmayacak

Benim gönderdiğim kodda bu tarafı yapamadım


Saygılarımla

 
  
 
Son düzenleme:
M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe
fakat yüzün, YÜZDEN, KÜÇÜK, GÜÇ VS. ifadeleri Kelimeler sayfasını B sütunda geçtiği için , iş listesi sayfasının B2 hücresinde bu kelimeler içerirse, varsa fontları boyama yapılmayacak
 
M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe
Merhabalar



Kod: 
KELİME DAHİL("*" İÇERİRSE) RENKLENDİR
YÜZ
BİN
TL
SEKİZ
LİRA
İKİ
ÜÇ
VS.

KELİME HARİÇ("*" İÇERİRSE) RENKLENDİRME
YÜZÜN
YÜZDEN
KÜÇÜK
GÜÇ
VS.
Kelimeler sayfasındaki Kelime dahil sütununda bulunan kelimeler iş listesi sayfasının B sütunun misal B2 hücresinde içeriyorsa(varsa) o içeren kelimeler veya harf/sayılar vs ... fontu maviye zemin rengi misal yeşil renge boyanacak


Kelimeler sayfasındaki Kelime hariç sütununda bulunan kelimeler iş listesi sayfasının B sütunun misal B2 hücresinde içeriyorsa(varsa) o içeren kelime veya harf/sayılar vs ... fontu hiç bir renge boyanmayacak

Örnek olarak verdiğim
yüz Cihazın0 panel kırık binsekizyüzlir yüzünden ifadesi

yüz Cihazın0 panel kırık binsekizyüzlir yüzünden (font maviye ayrıca zemin rengi de yeşil veya başka bir renkte olabilir) olacak

İş listesi B2 hücresindeki bulunan Yüz, bin, sekiz kelimesi Kelimeler sayfasını A sütunda geçtiği için bunlar maviye renklenecek ve zemin rengi misal yeşil olacak

fakat yüzün, YÜZDEN, KÜÇÜK, GÜÇ VS. ifadeleri Kelimeler sayfasının B sütununda geçtiği için , iş listesi sayfasının B2 hücresinde bu kelimeler içerirse, varsa fontları boyama yapılmayacak

Benim gönderdiğim kodda bu tarafı yapamadım


Saygılarımla
 
M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe
Merhabalar

dizi ile sorunu çözdüm

Kod: 
Option Explicit
Sub kelimedeBul()
Dim ws As Worksheet
Dim sh As Worksheet
Dim col As Collection
Dim shrng As Range
Dim shLr, shLr2, wsLr As Long
Dim sayac, shUzunluk, tekrar As Long
Dim i, j, k As Long
Dim str1, str2, str3, mbul As String
Dim arr() As Variant

Set ws = Data
Set sh = Kelimeler
Set col = New Collection

shLr = sh.Cells(Rows.Count, "A").End(xlUp).Row
shLr2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
wsLr = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws.Range("A2:B" & wsLr).Interior
    .Pattern = xlNone
End With
With ws.Range("A2:B" & wsLr).Font
    .ColorIndex = xlAutomatic
    .Bold = False
    .FontStyle = "Normal"
    .ColorIndex = xlAutomatic
End With

For i = 2 To wsLr
    str1 = UCase(Replace(ws.Cells(i, "B").Value, "i", "İ"))
    ReDim Preserve arr(2 To wsLr)
    arr(i) = UCase(Replace(ws.Cells(i, "B").Value, "i", "İ"))
   
    For j = 2 To shLr
        str2 = UCase(Replace(sh.Cells(j, "A").Value, "i", "İ"))
        str3 = UCase(Replace(sh.Cells(j, "B").Value, "i", "İ"))
     
        arr(i) = Replace(arr(i), str3, _
        Application.Rept("@", Len(str3)))
       
        arr(i) = Replace(arr(i), str2, _
        Application.Rept("#", Len(str2)))
       
    Next j
       
         tekrar = (Len(str1) - Len(Application.Substitute(arr(i), "#", "")))

        sayac = 1
        For k = 2 To tekrar + 1
           
            mbul = Application.Search("#", arr(i), sayac)
            sayac = mbul + 1
            shUzunluk = 1
           
            ws.Cells(i, "B").Characters(Start:=mbul, Length:=shUzunluk).Font.Color = vbBlue
            ws.Cells(i, "B").Characters(Start:=mbul, Length:=shUzunluk).Font.Bold = True
       
            ws.Range(ws.Cells(i, "A"), ws.Cells(i, "B")).Interior.Color = RGB(184, 204, 228)
            ws.Range(ws.Cells(i, "A"), ws.Cells(i, "B")).Font.Bold = True
           
        Next k
       
     

Next i


Set ws = Nothing
Set sh = Nothing
Set shrng = Nothing
Set col = Nothing

End Sub
 
M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe
Merhabalar;

Bu kod çok veri olunca derlemesi uzun olacaktır.

Alternatif hızlı kod önerisi olan var ve kodu yazarsa sevinirim.
 
M

mesudiye_052

Katılım
4 Nisan 2006
Mesajlar
999
Excel Vers. ve Dili
OFFICE 2021 Türkçe
Merhabalar;

kodu güncelledim

link

DENEME.xlsb

dosyayı indir, full download - DENEME.xlsb
dosya.org dosya.org

Option Explicit
Sub kelimedeBul()
Dim ws As Worksheet
Dim sh As Worksheet
Dim col As Collection
Dim shrng As Range
Dim shLr, shLr2, wsLr As Long
Dim sayac, shUzunluk, tekrar As Long
Dim i, j, k, l As Long
Dim str1, str2, str3, mbul As String
Dim arr() As Variant

Set ws = Data
Set sh = Kelimeler
Set col = New Collection

shLr = sh.Cells(Rows.Count, "A").End(xlUp).Row
shLr2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
wsLr = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws.Range("A2:B" & wsLr).Interior
.Pattern = xlNone
End With
With ws.Range("A2:B" & wsLr).Font
.ColorIndex = xlAutomatic
.Bold = False
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

For i = 2 To wsLr
str1 = UCase(Replace(ws.Cells(i, "B").Value, "i", "İ"))
ReDim Preserve arr(2 To wsLr)
arr(i) = UCase(Replace(ws.Cells(i, "B").Value, "i", "İ"))

For j = 2 To shLr
str2 = UCase(Replace(sh.Cells(j, "A").Value, "i", "İ"))

For l = 2 To shLr2
str3 = UCase(Replace(sh.Cells(l, "B").Value, "i", "İ"))
arr(i) = Replace(arr(i), str3, _
Application.Rept("@", Len(str3)))
Next l


arr(i) = Replace(arr(i), str2, _
Application.Rept("#", Len(str2)))

Next j

tekrar = (Len(str1) - Len(Application.Substitute(arr(i), "#", "")))

sayac = 1
For l = 2 To tekrar + 1

mbul = Application.Search("#", arr(i), sayac)
sayac = mbul + 1
shUzunluk = 1

ws.Cells(i, "B").Characters(Start:=mbul, Length:=shUzunluk).Font.Color = vbBlue
ws.Cells(i, "B").Characters(Start:=mbul, Length:=shUzunluk).Font.Bold = True

ws.Range(ws.Cells(i, "A"), ws.Cells(i, "B")).Interior.Color = RGB(184, 204, 228)
ws.Range(ws.Cells(i, "A"), ws.Cells(i, "B")).Font.Bold = True

Next l



Next i


Set ws = Nothing
Set sh = Nothing
Set shrng = Nothing
Set col = Nothing

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst