• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

B sütunundakileri A sütununda bulma

G

gunay.harun

Altın Üye
Katılım
25 Şubat 2016
Mesajlar
79
Excel Vers. ve Dili
Excel 2016 türkçe
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.
 

Ekli dosyalar

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)
 
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)
Genişletmek için tıkla ...
Makro olarak yardım edebilirmisiniz peki?
 
Ö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?
 
Son düzenleme:
@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
 
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?
Genişletmek için tıkla ...
Hayır at = at yani ateş in içindeki at' ı renklendirmeyecek
 
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
Genişletmek için tıkla ...
Teşekkürederim. Fakat sizin yazdığınız kod ile kelime = kelime araması yapıyor. Ben metin içerisinde kelime araması yapmak istiyorum.
 
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.

239462
 
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
 

Ekli dosyalar

  • Ad.png
    Ad.png
    6.2 KB · Görüntüleme: 2
Son düzenleme:
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
Genişletmek için tıkla ...
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.
 
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
Genişletmek için tıkla ...
Merhaba hocam. Ek olarak yüklediğiniz fotoyu yukarıdaki makro ile mi yaptınız? Sizdeki tablo benim istediğim gibi olmuş.
 
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.
 
#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
 
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
 
@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.
 
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
Genişletmek için tıkla ...
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.
 

Ekli dosyalar

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
 
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
 
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
Genişletmek için tıkla ...
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.
 
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst