- Katılım
- 25 Şubat 2016
- Mesajlar
- 64
- Excel Vers. ve Dili
- Excel 2016 türkçe
- Altın Üyelik Bitiş Tarihi
- 09-10-2024
Korhan hocam elinize sağlık işimi gördü. Çok tesekkurederimHer 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