بحث وتحويل الخط الى Bold والى اللون الازرق

[الســـــــاهر]

السلام عليكم

مبارك علينا وعليكم العشر الاواخر من الشهر الفضيل...

اخواني الكرام....

اريد كود عند تنفيذه يقوم بالبحث في ورقة العمل عن اي خلية تحتوي الكلمة in ويقوم بتحويل خطها الى Bold والى اللون الازرق.

وشكرا لكم مقدما

من فضلك لا تقوم برفع الملف مضغوط طالما حجمه صغير , وذلك تجنباً لعدم اهدار وقت الأساتذة

 

Bold.xlsm

تم تعديل مايو 15, 2020 بواسطه الســـــــاهر

[سليم حاصبيا]

جرب هذا الكود

Option Explicit
Dim La%, x%
Dim SW As Worksheet
Sub find_in(Rg As Range)
Dim obj As Object
Dim Mth, i, p, k%
    With Rg
    .Characters(1, Len(Rg)).Font.Color = 1
    .Font.Bold = False
    End With
Set obj = CreateObject("Vbscript.Regexp")
  With obj
    .Pattern = "\b(in)\b"
    .Global = True
    .ignorecase = True
    .MultiLine = True
  End With
If obj.test(Rg) Then

Set Mth = obj.Execute(Rg)
 For i = 0 To Mth.Count - 1
 p = InStr(1 + k, Rg, Mth(i))
 Rg.Characters(p, 2).Font.ColorIndex = 5
 Rg.Characters(p, 2).Font.Bold = True
 k = Len(Rg) - p
  Next
End If

End Sub
'++++++++++++++++++++++++++++++++++++
Sub Colorize()
Set SW = Sheets("Sheet1")
 La = SW.Cells(Rows.Count, 1).End(3).Row
  For x = 1 To La
   If SW.Cells(x, 1) <> vbNullString Then
    Call find_in(SW.Range("A" & x))
   End If
  Next

End Sub
'++++++++++++++++++++++++++++++++
Sub reset()
Set SW = Sheets("Sheet1")
 La = SW.Cells(Rows.Count, 1).End(3).Row
  For x = 1 To La
   If SW.Cells(x, 1) <> vbNullString Then
    With SW.Cells(x, 1)
     .Characters(1, Len(.Value)).Font.Color = 1
     .Font.Bold = False
    End With
   End If
  Next
End Sub

الملف مرفق

 

Saerch_In.xlsm

[الســـــــاهر]

الاستاذ الفاضل سليم

جزاكم الله خير على هذا العمل الرائع وبارك الله لكم

لكن اخي هناك مشكلة وهي ان الكود يقوم بالتعامل مع العمود A فقط وانا اريده على كامل الورقة وايضا بعض الكلمات التي فيها حرفي in مثلا الكلمة talin وانا اريد فقط التعامل مع حرفي In ككلمة منفصلة بذاتها وليس حرفين

ارجو اني اوضحت المطلوب <وشكرا لك استاذي الفاضل

[سليم حاصبيا]

تم التعديل مرة أخرى و بإضافت جديدة

1-حرية اختيار الكلمة لتلوينها و تكبير الخط فيها (الخلية F1 )

2-حرية اخنيار لون التلوين (الخلية G1 )

3- الكود

Option Explicit

Sub Regex_position(aSrting As Range, ByVal My_ExP As String)
    Dim rex As Object
    Dim Array_Pos() As Integer
    Dim Array_Mot() As String
    Dim Cnt%
    Dim My_Match, Sing_Match
Set rex = CreateObject("Vbscript.Regexp")
 With rex
  .Pattern = My_ExP: .ignorecase = True: .Global = True
 End With
 If rex.test(aSrting) Then
  Set My_Match = rex.Execute(aSrting)
   Cnt = 0
   For Each Sing_Match In My_Match
    ReDim Preserve Array_Pos(Cnt)
    ReDim Preserve Array_Mot(Cnt)
     Array_Pos(Cnt) = Val(Sing_Match.firstindex + 1)
     Array_Mot(Cnt) = Sing_Match
    Cnt = Cnt + 1
    Next
   For Cnt = LBound(Array_Pos) To UBound(Array_Pos)
   With aSrting.Characters(Array_Pos(Cnt), Len(Array_Mot(Cnt))).Font
    .ColorIndex = Sheets("sheet1").Range("G1")
    .Size = 20: .Bold = True
   End With
    Next
  End If

End Sub
'++++++++++++++++++++++++++++++++++++

Sub Colorize_Please()
Application.ScreenUpdating = False
Dim st, cel As Range
st = "(?:^|\W)" & Range("F1") & "(?:$|\W)"
'With Range("a1:a13")
With Sheets("Sheet1").UsedRange
.Characters.Font.ColorIndex = 1
.Font.Bold = False
.Font.Size = 16
End With
'For Each cel In Range("a1:a13")
For Each cel In Sheets("Sheet1").UsedRange
 Call Regex_position(cel, st)
Next
 With Sheets("Sheet1").Range("F1:G1").Font
  .ColorIndex = 1: .Bold = True: .Size = 20
 End With
Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++
Sub reset_me()
With Sheets("Sheet1").UsedRange.Font
.ColorIndex = 1: .Bold = False: .Size = 16
End With
With Sheets("Sheet1").Range("F1:G1").Font
  .ColorIndex = 1: .Bold = True: .Size = 20
End With
End Sub

الملف مرفق

 

All_Saerch_New.xlsm

[الســـــــاهر]

السلام عليكم

الاستاذ الفاضل سليم حاصبيا

اشكرك جزيل الشكر هذا هو المطلوب وهو فعلا كنت حاب يكون متعدد الخيارات من حيث الكلمة او اللون والحجم

لكن ليس لدي مساحة في ورقة العمل لذلك قمت بعمل فورم  على الكود الاول مع مراعاة عدم الغاء اللون في كل مرة.

انا عارف اني تعبت حضرتك فجزاك الله خير

اتمنى لو تركب الكود الاخير على الفورم لاني حاولت ماقدرت

الملف بالمرفقات

اشكرك مرة اخرى...

All_Saerch_In 1.xlsm

[سليم حاصبيا]

أنا لا أتعامل مع اليوزرفورم لأن خبرتي فيه قليلة ( ولا أحبه اصلاً)

ولا أي عمل من أعمالي يحتوي على يوزر فورم

ممكن أن يقوم بهذا العمل  احد الاساتذة ممن لديهم الخبرة الكافية باليوزرفورم

[الســـــــاهر]

السلام عليكم

تم بحمد الله تركيب الكود والفضل والشكر لله ثم للأستاذ الفاضل سليم حاصبيا

جزاك الله خير الجزاء...

All_Saerch_In 2.xlsm

[سليم حاصبيا]

تم عمل المطلوب

يبدو ان الأمر كان سهلاً  (الكومبو بوكس لا يستقبل الكتابة بواسطة الكيبورد   تفادياً للخطأ) يمكن ادراج القيم فقط من حلال قائمته المنسدلة

كذلك يمكنك التنقل داخل الشيت حتى ولو كان اليوزرفورم ظاهراً

All_Saerch_In With_User.xlsm

[الســـــــاهر]

السلام عليكم

الاستاذ الكريم سليم حاصبيا

جزاك الله خير الجزاء هذا اكثر من المطلوب ماقصرت اخي الفاضل

جعل الله ماتقدم في ميزان حسناتك

All_Saerch_In With_User (1).xlsm

[سليم حاصبيا]

التعديل رائع على الكود 

لكن عندي ملاحظة بالنسبة لهذا الجزء منه (5 سطور)

  If Me.CheckBox1.Value = True Then
    .Bold = True
    Else
    .Bold = False
   End If

حيث يمكن استبداله بسطر واحد

.Bold = Me.CheckBox1.Value

 

[الســـــــاهر]

السلام عليكم

الاستاذ الكريم سليم حاصبيا

تم تعديل الكود مع إضافة إعادة تعيين فردي (لكلمة واحدة دون الكل)

أشكرك مرة أخرى

All_Saerch_In With_User (1).xlsm

[سليم حاصبيا]

صديقي

    لست بحاجة الى ادراج  ماكرو آخر  لهذا الغرض  يكفي 2 تشيك بوكس    واحد (لجميع الكلمات  او  أول كلمة )  والثاني  (Bold Or Not)

انظر الى هذا الملف

All_Saerch_In With_User_Option.xlsm

[احمد ابوزيزو]

سليم حاصبيا

السلام عليكم

هل يمكن استخدام نفس الكود بنفس الطريقة

لبرنامج الوورد WORD

[الســـــــاهر]

السلام عليكم

الاستاذ الكريم سليم حاصبيا

لم اقصد اول كلمة في الخلية وانما قصدت كلمة واحدة من ضمن عدة كلمات  يعني لو عاوزين نلغي التحرير اللي اتعمل على كلمة IN مع الابقاء على باقي الكلمات محرره لذلك اضفت زر ٌReset one" بمعنى الغاء تحرير كلمة واحدة والتي تكون مكتوبة في بوكس البحث.

اعجبني الكود الجديد للكلمة الاولى فقمت بتركيبه مع إضافة امكانية تغير الخط الى Italic و underline

أشكرك من صميم فؤادي...

All_Saerch_In With_User full edit.xlsm

[سليم حاصبيا]

لا حاجة لاضافة مزيد من الازرار او اضافة ماكرو  لتحديد المزيد من الخيارات

ولا حاجة ايضاً بأن تكون الكلمة المطلوبة في TextBox1 عند تنشيط اليوزر  هي "In"

عناوين الــ Labels تتغير حسب الـ  CheckBox   المختار

Extra_Search.xlsm

[الســـــــاهر]

السلام عليكم

الاستاذ الكريم سليم حاصبيا

اولا اشكر لك اهتمامك المعهود ... جزاك الله خير

الفكرة هي ان ممكن تكون كلمات الجملة مكونة من اكثر من لون  مثال:

The cat is under the table.

فلو اردنا ان نلغي تحرير under مع الابقاء على باقي الكلمات كما هي فتصبح

The cat is under the table.

لذلك عملت زر الغاء تحرير كلمة واحدة مع ترك بقية الكلمات كما هي

اعجبني الكود الجديد بما فيه من اختصارات فنية رائعة فركبته مع إضافة إمكانية التبديل بيع الغاء تحرير الكل او الغاء تحرير كلمة واحدة

أشكرك جزيل الشكر على اهتمامك ... بارك الله لك في علمك

Extra_Search1.xlsm