Liste 1'de varsa renklendirmek ve liste 2'deki karşılığını yazmak

[N.Faruk]

http://dosya.co/m80xph08y6i3/Kitap1.xlsx.html

 

[N.Faruk]

Arkadaşlar resimde açıklama yapmaya çalıştım.

Yardımlarınızı bekliyorum.

 

[PLİNT]

Merhaba
Ek dosyayı incelermisiniz?
http://s3.dosya.tc/server6/0pyklo/renkli.zip.html

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address <> "$F$1" Then Exit Sub
[e7:f1000] = ""
Cells.Font.ColorIndex = xlAutomatic
[f3].Value = [f1].Value
Application.EnableEvents = False
For s = 2 To Cells(Rows.Count, 1).End(3).Row
    Set c = [f1].Find(Trim(Cells(s, 1).Value), Lookat:=xlPart)
    If Not c Is Nothing Then
    x = x + 1
    Cells(6 + x, 5) = Cells(s, 1).Value
    Cells(6 + x, 5).Font.ColorIndex = 3
    Cells(6 + x, 6) = Cells(s, 2).Value
    [f3].Characters(Start:=InStr(UCase([f1]), UCase(Trim(Cells(s, 1).Value))), Length:=Len(Trim(Cells(s, 1).Value))).Font.ColorIndex = 3
    End If
Next
Application.EnableEvents = True
End Sub

 

[N.Faruk]

Çok teşekkür ederim. Gayet güzel çalışıyor.

Ancak tasarımı değiştirmek istediğimde hata aldım.

Yazmış olduğunuz kodları yeni tasarıma uyarlamaya çalıştım ama pek bilgim olmadığı için başarılı olamadım.

Kodlarda nasıl bir düzenleme yapmam gerekiyor ?

Yeni tasarımın olduğu excel dosyası aşağıdaki linktedir.

http://dosya.co/q7yf3zapjtkp/Kitap3.xlsx.html

 

[N.Faruk]

Arkadaşlar makrodan anlayıp da yardım edebilecek yok mu?

Ya da fonksiyonlarla yapabilen varsa o da olur. Yeter ki şunu bir neticeye kavuşturalım.

Yardımlarınızı bekliyorum.

 

[PLİNT]

Merhaba
Dosyanız ekde;
http://s6.dosya.tc/server4/xf56xr/Kopya_renk.zip.html

Son dosyanızı inceleyince;
"uç" - "Havuç"
gibi bir durum ortaya çıkıyor. Bu duruma göre değiştirmek gerekirse dosyadaki kodların ilgili bölümünü aşağıdaki şekilde değiştirin.

 For s = 3 To Cells(Rows.Count, "B").End(3).Row
    Set c = Columns("h:p").[COLOR="Red"]Find(" " & Trim[/COLOR](Cells(s, 2).Value), LookAt:=xlPart)
    If Not c Is Nothing Then

 

[N.Faruk]

Bir sonraki sorum bu olacaktı Çok çok teşekkür ederim.

Ancak ilgili bölümü aşağıdaki kodlar ile değiştirdiğim zaman ilk kelimeyi liste 1 de olsa dahi kırmızı olarak göstermiyor.

 For s = 3 To Cells(Rows.Count, "B").End(3).Row
    Set c = Columns("h:p").Find(" " & Trim(Cells(s, 2).Value), LookAt:=xlPart)
    If Not c Is Nothing Then

Aşağıdaki kod satırında " " kısmını "" olarak değiştirirsem ilk kelimeyi buluyor ama bu sefer de uç-havuç durumu yine ortaya çıkıyor.

Set c = Columns("h:p").Find(" " & Trim(Cells(s, 2).Value), LookAt:=xlPart)

Bu durumda ne yapmamız lazım ?

 

[PLİNT]

Bir sonraki sorum bu olacaktı Çok çok teşekkür ederim.
Aşağıdaki kod satırında " " kısmını "" olarak değiştirirsem ilk kelimeyi buluyor ama bu sefer de uç-havuç durumu yine ortaya çıkıyor.

Set c = Columns("h:p").Find(" " & Trim(Cells(s, 2).Value), LookAt:=xlPart)

Bu durumda ne yapmamız lazım ?

Bu durum için aşağıdaki gibi bir çözüm üretilebilir.;

 Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address <> "$H$2" Then Exit Sub
[e3:f1000] = ""
Cells.Font.ColorIndex = xlAutomatic
Application.EnableEvents = False
[H2].Value = Trim([H2].Value)
[H12].Value = " " & [H2].Value
[H2].Value = [H12].Value
For s = 3 To Cells(Rows.Count, "B").End(3).Row
    Set c = Columns("h:p").Find(" " & Trim(Cells(s, 2).Value), LookAt:=xlPart)
    If Not c Is Nothing Then
    x = x + 1
    Cells(2 + x, "E") = Cells(s, "B").Value
    Cells(2 + x, "E").Font.ColorIndex = 3
    Cells(2 + x, "F") = Cells(s, "C").Value
    [H12].Characters(Start:=InStr(UCase([H2]), UCase(Trim(Cells(s, "B").Value))), Length:=Len(Trim(Cells(s, "B").Value))).Font.ColorIndex = 3
    End If
Next
Set c = Nothing
Application.EnableEvents = True
End Sub

 

[N.Faruk]

Teşekkür ederim. O problem de halloldu.
Ancak bu sefer daha farklı bir problem var. Deneme yaparken şöyle bir şey farkettim.
Farklı yerlerde geçen aynı kelimelerden sadece ilk kelimeyi kırmızıya boyuyor. İkinciyi boyamıyor.

Mesela "aday adayı" yazdığım zaman iki kelime de liste 1 de var fakat sadace ilk "aday" kelimesini kırmızı yapıyor.

(İkisini de kırmızıya boyamalı fakat listeye sadece birini eklemeli. Mevcut durumda ise birini kırmızı yapıyor ve onu listeye ekliyor.)

Bir de sadece "havuç" yazdığım zaman sorun yok.
Ama "havuç uçları" yazdığım zaman normalde "uçları" kelimesindeki "uç" kırmızı olmalı fakat "havuç" kelimesindeki "uç" kırmızı oluyor.

Yani mesela bir cümle yazdım ve içinde 4 tane aday kelimesi geçti. Bunların hepsini kırmızı yapmalı ama listeye bir tanesini eklemeli.

Bahsi geçen hatalar aşağıdaki resimde gösterilmiştir.

Teşekkür ederim.

 

[PLİNT]

Teşekkür ederim. O problem de halloldu.
Ancak bu sefer daha farklı bir problem var.

Merhaba

Mesela şöyle bir durumda olabilir:
Kelime: "FİŞ", karşılığı: "YAZARKASA"
Kelime: "FİŞ", karşılığı: "ELEKTRİK"

Birde aşağıdaki şekilde deneyiniz.

 Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address <> "$H$2" Then Exit Sub
[e3:f10000] = ""
[h12] = [h2]
[h12].Font.ColorIndex = xlAutomatic
Application.EnableEvents = False
For a = 1 To Len(Trim([h2].Value))
If Mid([h2].Value, a, 1) = " " Then
b = Empty: x = 0
Else
b = b & Mid([h2].Value, a, 1)
If x = 0 Then x = a
If Len(b) >= 2 Then
Set c = Range("b2:b" & Cells(Rows.Count, "b").End(3).Row).Find(b, after:=[b2], lookat:=xlWhole)
If Not c Is Nothing Then
[h12].Characters(x, Len(b)).Font.ColorIndex = 3
j = Cells(Rows.Count, "e").End(3).Row + 1
m = WorksheetFunction.CountIf(Range("e3:e" & j), b)
m2 = WorksheetFunction.CountIf(Range("b3:b" & Cells(Rows.Count, "b").End(3).Row), b)
If m < m2 Then
Range("e" & j & ":f" & j).Value = Range("b" & c.Row & ":c" & c.Row).Value
Range("e" & j).Font.ColorIndex = 3
If m2 > 1 Then
u = c.Row
For a2 = 1 To m2 - 1
Set c2 = Range("b" & u & ":b" & Cells(Rows.Count, "b").End(3).Row).Find(b, after:=Range("b" & u), lookat:=xlWhole)
If Not c2 Is Nothing Then
j = Cells(Rows.Count, "e").End(3).Row + 1
Range("e" & j & ":f" & j).Value = Range("b" & c2.Row & ":c2" & c.Row).Value
Range("e" & j).Font.ColorIndex = 3
u = c2.Row
End If:
Next
End If
End If
End If:
End If
End If
Set c = Nothing
Next
Application.EnableEvents = True
End Sub

 

[N.Faruk]

Teşekkür ederim...

İşte bu! Efendim bu son haliyle herhangi bir problem görünmüyor. Çoook çok teşekkür ederim.