B sütunundakileri A sütununda bulma

gunay.harun · 27 Eylül 2022

Merhabalar.
Ek teki dosyada B stunudaki kelimeleri A stunudaki hücreler içinde tespit etmek ve tespit edilen kelimenin renginin değişmesini istiyorum. Koşullu biçimlendirmeden formül yazılarak olursa sevinirim.

YUSUF44 · 27 Eylül 2022

Formülle hücrenin içindeki bir kelimenin (ya da hücrenin bir kısmının) biçimi değiştirilemez.
Formülle hücre içeriğinin bir kısmı değiştirilemez.
B1'de yazan bir kelime A2 hücresinde geçiyorsa A2 hücresindeki o kelimenin biçimini değiştirmek için makro kullanmak şarttır. (Tabi microsoft gelecek sürümlere böyle bir özellik eklerse bir şey diyemem)

gunay.harun · 27 Eylül 2022

YUSUF44' Alıntı:
Formülle hücrenin içindeki bir kelimenin (ya da hücrenin bir kısmının) biçimi değiştirilemez.
Formülle hücre içeriğinin bir kısmı değiştirilemez.
B1'de yazan bir kelime A2 hücresinde geçiyorsa A2 hücresindeki o kelimenin biçimini değiştirmek için makro kullanmak şarttır. (Tabi microsoft gelecek sürümlere böyle bir özellik eklerse bir şey diyemem)

Makro olarak yardım edebilirmisiniz peki?

YUSUF44 · 27 Eylül 2022

Örneğin "at" için konuşursak A1 hücresinde "ateşle oynamak tehlikelidir" ifadesi olduğunda "ateş"in "at"ı renklenecek mi? Ya da "Bu ne surat?"taki "at" renklenecek mi?

Korhan Ayhan · 27 Eylül 2022

@YUSUF44 beyin soruları önem arz ediyor.

Ben bir kod hazırladım. Deneyiniz.

C++:

Option Explicit

Sub Color_Search_Data()
    Dim Rng As Range, All_Find_Text As Object, Find_Text As Object
    
    Application.ScreenUpdating = False
    
    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False
    
    With VBA.CreateObject("VBscript.RegExp")
        For Each Rng In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            If Rng.Offset(, 1).Value <> "" Then
                .Pattern = "(" & Rng.Offset(, 1).Value & ")"
                .Global = True
                
                Set All_Find_Text = .Execute(Rng.Value)
                
                For Each Find_Text In All_Find_Text
                    Rng.Characters(Find_Text.FirstIndex + 1, Find_Text.Length).Font.Bold = True
                    Rng.Characters(Find_Text.FirstIndex + 1, Find_Text.Length).Font.Color = vbRed
                Next
            End If
        Next
    End With

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

gunay.harun · 27 Eylül 2022

YUSUF44' Alıntı:
Örneğin "at" için konuşursak A1 hücresinde "ateşle oynamak tehlikelidir" ifadesi olduğunda "ateş"in "at"ı renklenecek mi? Ya da "Bu ne surat?" daki "at" renklenecek mi?

Hayır at = at yani ateş in içindeki at' ı renklendirmeyecek

gunay.harun · 27 Eylül 2022

Korhan Ayhan' Alıntı:

@YUSUF44 beyin soruları önem arz ediyor.

Ben bir kod hazırladım. Deneyiniz.

C++:

Option Explicit

Sub Color_Search_Data()
    Dim Rng As Range, All_Find_Text As Object, Find_Text As Object
   
    Application.ScreenUpdating = False
   
    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False
   
    With VBA.CreateObject("VBscript.RegExp")
        For Each Rng In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            If Rng.Offset(, 1).Value <> "" Then
                .Pattern = "(" & Rng.Offset(, 1).Value & ")"
                .Global = True
               
                Set All_Find_Text = .Execute(Rng.Value)
               
                For Each Find_Text In All_Find_Text
                    Rng.Characters(Find_Text.FirstIndex + 1, Find_Text.Length).Font.Bold = True
                    Rng.Characters(Find_Text.FirstIndex + 1, Find_Text.Length).Font.Color = vbRed
                Next
            End If
        Next
    End With

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkürederim. Fakat sizin yazdığınız kod ile kelime = kelime araması yapıyor. Ben metin içerisinde kelime araması yapmak istiyorum.

YUSUF44 · 27 Eylül 2022

Korhan Bey'in çözümünü denediniz mi bilmiyorum ama ben deneyince görüntüdeki sonuç çıktı, yani A sütunundaki kelimeler renklendi. Siz nasıl bir sonuç istiyordunuz ki?

Bir de benim sorduğum soruyla bağlantılı olarak A3 hücresinde hem "sucuk"taki su hem de müstakil "su" renklendi.

Tevfik_Kursun · 27 Eylül 2022

Merhaba Arkadaşım,
Dikkat #6. mesaja cevaptır.
sadece "at" kelimesini belirtmek istiyorsanız; cümle içinde ise " at " şeklinde iki tarafına da boşluk koyunuz. Cümle başında ya da sonunda ise önce ya da sonrasına boşluk koyunuz. Örnekte "Aliye" var. (Not : isimlerin hepsi sahte, kesinlikle gerçek değildir)
iyi çalışmalar

gunay.harun · 27 Eylül 2022

YUSUF44' Alıntı:
Korhan Bey'in çözümünü denediniz mi bilmiyorum ama ben deneyince görüntüdeki sonuç çıktı, yani A sütunundaki kelimeler renklendi. Siz nasıl bir sonuç istiyordunuz ki?

Bir de benim sorduğum soruyla bağlantılı olarak A3 hücresinde hem "sucuk"taki su hem de müstakil "su" renklendi.

Ekli dosyayı görüntüle 239462

Hocam şöyle ki; örneğin b1 deki "at" sadece a1 de kırmızı oluyor. A stunundaki diğer hücrelerde renklenmiyor. Benim isteğim ise b1 de yada b nin başka hücrelerinde at yada başka bir kelimeyi A stunundaki tüm hücrelerde renklenmesi.

gunay.harun · 27 Eylül 2022

Tevfik_Kursun' Alıntı:
Merhaba Arkadaşım,
Dikkat #6. mesaja cevaptır.
sadece "at" kelimesini belirtmek istiyorsanız; cümle içinde ise " at " şeklinde iki tarafına da boşluk koyunuz. Cümle başında ya da sonunda ise önce ya da sonrasına boşluk koyunuz. Örnekte "Aliye" var. (Not : isimlerin hepsi sahte, kesinlikle gerçek değildir)
iyi çalışmalar

Merhaba hocam. Ek olarak yüklediğiniz fotoyu yukarıdaki makro ile mi yaptınız? Sizdeki tablo benim istediğim gibi olmuş.

Tevfik_Kursun · 27 Eylül 2022

Evet, işinizi görürse buyrun;

Kod:

Option Explicit

Sub Color_Search_Data()
    Dim Rng As Range, All_Find_Text As Object, Find_Text As Object
    Dim Son As Long, Aranan As String
    Application.ScreenUpdating = False

    Son = Cells(Rows.Count, 91).End(3).Row
    Range("CM3:CM" & Son).Font.Bold = False
    Range("CM3:CM" & Son).Font.Color = False
   
    With VBA.CreateObject("VBscript.RegExp")
        For Each Rng In Range("CM3:CM" & Son)
        Aranan = Range("CD6").Value
            If Aranan <> "" Then
                .Pattern = "(" & Aranan & ")"
                .Global = True
               
                Set All_Find_Text = .Execute(Rng.Value)
               
                For Each Find_Text In All_Find_Text
                    Rng.Characters(Find_Text.FirstIndex + 1, Find_Text.Length).Font.Bold = True
                    Rng.Characters(Find_Text.FirstIndex + 1, Find_Text.Length).Font.Color = vbRed
                Next
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Belki aranan bulunamadı diye bir mesaj eklense daha güzel olurdu.
iyi çalışmalar.

Korhan Ayhan · 27 Eylül 2022

#6 nolu mesajınızda ki kurala göre ve örnek dosyanızda ki verilere göre aşağıdaki kodu deneyebilirsiniz.

C++:

Option Explicit

Sub Color_Search_Data()
    Dim Rng As Range, All_Find_Text As Object, Find_Text As Object
   
    Application.ScreenUpdating = False
   
    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False
   
    With VBA.CreateObject("VBscript.RegExp")
        For Each Rng In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            If Rng.Offset(, 1).Value <> "" Then
                .Pattern = "( " & Rng.Offset(, 1).Value & " )"
                .Global = True
               
                Set All_Find_Text = .Execute(" " & Rng.Value & " ")
               
                For Each Find_Text In All_Find_Text
                    Rng.Characters(Find_Text.FirstIndex, Find_Text.Length - IIf(Find_Text.FirstIndex = 0, 2, 0)).Font.Bold = True
                    Rng.Characters(Find_Text.FirstIndex, Find_Text.Length - IIf(Find_Text.FirstIndex = 0, 2, 0)).Font.Color = vbRed
                Next
            End If
        Next
    End With

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Tevfik_Kursun · 27 Eylül 2022

Sayın Korhan Hocam,
Bulamadığında Find_Text = Nothing oluyor. MsgBox "İşleminiz tamamlanmıştır.", vbInformation yerine "bu ifade bulunamadı" nasıl denir, burada?
Saygılarımla

Korhan Ayhan · 27 Eylül 2022

@Tevfik_Kursun,

Birden fazla satırda arama işlemi yapılıyor. Bu sebeple talebiniz bana çok mantıklı gelmedi. Neden derseniz binlerce satırlık bir tabloda bu şekilde sonuç almak istediğinizde ve yüzlerce olmayan veri varsa karşınıza sürekli MSGBOX gelecektir. Bence bu çok can sıkıcı bir sonuç olacaktır.

Ayrıca zaten aranan veri renklendiği için kullanıcı rengi takip ederek kontrol sağlayabilecektir.

gunay.harun · 27 Eylül 2022

Korhan Ayhan' Alıntı:

#6 nolu mesajınızda ki kurala göre ve örnek dosyanızda ki verilere göre aşağıdaki kodu deneyebilirsiniz.

C++:

Option Explicit

Sub Color_Search_Data()
    Dim Rng As Range, All_Find_Text As Object, Find_Text As Object

    Application.ScreenUpdating = False

    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False

    With VBA.CreateObject("VBscript.RegExp")
        For Each Rng In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            If Rng.Offset(, 1).Value <> "" Then
                .Pattern = "( " & Rng.Offset(, 1).Value & " )"
                .Global = True
            
                Set All_Find_Text = .Execute(" " & Rng.Value & " ")
            
                For Each Find_Text In All_Find_Text
                    Rng.Characters(Find_Text.FirstIndex, Find_Text.Length - IIf(Find_Text.FirstIndex = 0, 2, 0)).Font.Bold = True
                    Rng.Characters(Find_Text.FirstIndex, Find_Text.Length - IIf(Find_Text.FirstIndex = 0, 2, 0)).Font.Color = vbRed
                Next
            End If
        Next
    End With

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan hocam bunu denedim fakat yine aynı. Örneğin b1 deki at kelimesi sadece a1 de renkleniyor.
istediğim sonucu renklendirerek Ekliyorum hocam. Yardımcı olursanız çok sevinirim.

YUSUF44 · 27 Eylül 2022

Aşağıdaki makroyu dener misiniz? Hem başta hem sonda hem de arada olan kelimeleri B sütunundaki tüm kelimelerle karşılaştırıyor:

PHP:

Sub renkle()
son = Cells(Rows.Count, "A").End(3).Row
Range("A:A").Font.Bold = False
Range("A:A").Font.Color = False
Application.ScreenUpdating = False
    For i = 1 To son
        veri = Split(Cells(i, "A"), " ")
        For k = 1 To son
            If veri(0) = Cells(k, "B") Then
                Cells(i, "A").Characters(1, Len(veri(0))).Font.Bold = True
                Cells(i, "A").Characters(1, Len(veri(0))).Font.Color = vbRed
            ElseIf veri(UBound(veri)) = Cells(k, "B") Then
                Cells(i, "A").Characters(Len(Cells(i, "A")) - Len(veri(UBound(veri))), Len(veri(UBound(veri))) + 1).Font.Bold = True
                Cells(i, "A").Characters(Len(Cells(i, "A")) - Len(veri(UBound(veri))), Len(veri(UBound(veri))) + 1).Font.Color = vbRed
            Else
                For m = 1 To UBound(veri) - 1
                    If veri(m) = Cells(k, "B") Then
                        For n = 1 To Len(Cells(i, "A"))
                            If Mid(Cells(i, "A"), n, Len(Cells(k, "B")) + 2) = " " & Cells(k, "B") & " " Then
                                Cells(i, "A").Characters(n, Len(veri(m)) + 1).Font.Bold = True
                                Cells(i, "A").Characters(n, Len(veri(m)) + 1).Font.Color = vbRed
                            End If
                        Next
                    End If
                Next
            End If
        Next
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı", vbInformation, "TAMAM"
End Sub

Korhan Ayhan · 27 Eylül 2022

Her satırı kendi içinde değerlendirmiştim. Siz B sütunundaki tüm verilerin A sütununda her satırda aranmasını istiyorsunuz.

Aşağıdaki kodu deneyebilirsiniz.

C++:

Option Explicit

Sub Color_Search_Data()
    Dim Rng As Range, All_Find_Text As Object, X As Long
    Dim My_Data As Variant, Find_Text As Object
    Dim Pattern_Array As Object, My_Pattern As Variant

    Application.ScreenUpdating = False

    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False

    My_Data = Range("B1:B" & Cells(Rows.Count, 2).End(3).Row).Value

    Set Pattern_Array = VBA.CreateObject("Scripting.Dictionary")
    
    For X = LBound(My_Data) To UBound(My_Data)
        If My_Data(X, 1) <> "" Then
            Pattern_Array.Add My_Data(X, 1), False
        End If
    Next
    
    With VBA.CreateObject("VBScript.RegExp")
        For Each Rng In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            For Each My_Pattern In Pattern_Array.Keys
                .Pattern = "( " & My_Pattern & " )"
                .Global = True
            
                Set All_Find_Text = .Execute(" " & Rng.Value & " ")
            
                For Each Find_Text In All_Find_Text
                    Rng.Characters(Find_Text.FirstIndex, Find_Text.Length - IIf(Find_Text.FirstIndex = 0, 2, 0)).Font.Bold = True
                    Rng.Characters(Find_Text.FirstIndex, Find_Text.Length - IIf(Find_Text.FirstIndex = 0, 2, 0)).Font.Color = vbRed
                Next
            Next
        Next
    End With
    
    Erase My_Data
    Pattern_Array.RemoveAll
    
    Set Pattern_Array = Nothing
    
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

gunay.harun · 27 Eylül 2022

YUSUF44' Alıntı:

Aşağıdaki makroyu dener misiniz? Hem başta hem sonda hem de arada olan kelimeleri B sütunundaki tüm kelimelerle karşılaştırıyor:

PHP:

Sub renkle()
son = Cells(Rows.Count, "A").End(3).Row
Range("A:A").Font.Bold = False
Range("A:A").Font.Color = False
Application.ScreenUpdating = False
    For i = 1 To son
        veri = Split(Cells(i, "A"), " ")
        For k = 1 To son
            If veri(0) = Cells(k, "B") Then
                Cells(i, "A").Characters(1, Len(veri(0))).Font.Bold = True
                Cells(i, "A").Characters(1, Len(veri(0))).Font.Color = vbRed
            ElseIf veri(UBound(veri)) = Cells(k, "B") Then
                Cells(i, "A").Characters(Len(Cells(i, "A")) - Len(veri(UBound(veri))), Len(veri(UBound(veri))) + 1).Font.Bold = True
                Cells(i, "A").Characters(Len(Cells(i, "A")) - Len(veri(UBound(veri))), Len(veri(UBound(veri))) + 1).Font.Color = vbRed
            Else
                For m = 1 To UBound(veri) - 1
                    If veri(m) = Cells(k, "B") Then
                        For n = 1 To Len(Cells(i, "A"))
                            If Mid(Cells(i, "A"), n, Len(Cells(k, "B")) + 2) = " " & Cells(k, "B") & " " Then
                                Cells(i, "A").Characters(n, Len(veri(m)) + 1).Font.Bold = True
                                Cells(i, "A").Characters(n, Len(veri(m)) + 1).Font.Color = vbRed
                            End If
                        Next
                    End If
                Next
            End If
        Next
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı", vbInformation, "TAMAM"
End Sub

Yusuf hocam yazdığınız kodu uyguladığımda excel yanıt vermiyor uyarısıyla beraber halen işlem yaptığını gösteren bir imleç dönüyor. 850 satır var işlem yapacağı acaba beklesem işlemi tamamlar mı? Normalde bir kaç satıra verdiğiniz kod çok güzel işliyor.

YUSUF44 · 27 Eylül 2022

850 satır demek en az 850*850 kez işlem yapmak demektir ki çoğunda daha fazla işlem yapılır. Bu da exceli çok yorar elbette. Dosyanızda formülle ve bağlantılar varsa iş yükü daha da artar.

Korhan Bey'in makrosunu deneyin, belki o daha hızlı ve verimli olabilir.

B sütunundakileri A sütununda bulma

gunay.harun

Ekli dosyalar

YUSUF44

Destek Ekibi

gunay.harun

YUSUF44

Destek Ekibi

Korhan Ayhan

Administrator

gunay.harun

gunay.harun

YUSUF44

Destek Ekibi

Tevfik_Kursun

Ekli dosyalar

gunay.harun

gunay.harun

Tevfik_Kursun

Korhan Ayhan

Administrator

Tevfik_Kursun

Korhan Ayhan

Administrator

gunay.harun

Ekli dosyalar

YUSUF44

Destek Ekibi

Korhan Ayhan

Administrator

gunay.harun

YUSUF44

Destek Ekibi