تنسيق شرطي

[ابو حمادة]

محتاج كود تنسيق شرطي

اذا كانت اي خليه في العمود (  B  ) تحتوى علي اى عنوان من العناوين الاربعه المظللة باللون الاخضر

يتم توسيطها بين العمود (  B  )  الي العمود  ( N  ) ويتم تغيير حجم الخط ليكون 20 او 24 واذا تم تغيير محتوى الخلية يتم تنسيق الخليه تنسيق الكتابه من اليمين

كما موضح  علما ان هذه العناوين قابله ان تنتقل لصفوف اخرى اعلى او اسفل

مرفق ملف للتوضيح

وجزاكم الله خيرا

تنسيق شرطى.rar

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

جرب هذا الماكرو

Sub Salim()
Dim Mg As Range
Set Mg = Range("p1:p4")

    With Range("B6:N22")
        .HorizontalAlignment = xlGeneral
        .Font.Size = 16
    End With
    
    For i = 6 To 22
        With Range("b" & i)
            For j = 1 To 4
                   If .Value = Mg.Cells(j) Then
                       .Font.Size = 24
                       .Resize(1, 13).HorizontalAlignment = xlCenterAcrossSelection
                   End If
             Next
        End With
    Next
  End Sub

 

[ابو حمادة]

بجد لساني عاجز عن الشكر استاذي افاضل سليم 

هو دا المطلوب 

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

وجزاك لله خيرا علي هذا المجهود

 

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

5 ساعات مضت, ابو حمادة said:

بجد لساني عاجز عن الشكر استاذي افاضل سليم 

هو دا المطلوب 

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

وجزاك لله خيرا علي هذا المجهود

 

جرب هذا الماكرو

Sub Salim()
Dim Mg As Range
Set Mg = Range("p1:p4")

    With Range("B6:N22")
        .HorizontalAlignment = xlGeneral
        .Font.Size = 16
    End With
    
    For i = 6 To 22
        With Range("b" & i)
            For j = 1 To 4
                   If .Value = Mg.Cells(j) Then
                       .Font.Size = 24
                       .Resize(1, 13).HorizontalAlignment = xlCenterAcrossSelection
                   End If
             Next
        End With
    Next
  End Sub

لك ما تريد

تم التعديل قليلاً على الماكرو ليعمل بشكل اسرع للبيانات الكثيرة

Sub Salim1()
Dim lr As Integer
Application.ScreenUpdating = False

If ActiveSheet.Name <> "ورقة1" Then Exit Sub
     lr = Cells(Rows.Count, 2).End(3).Row
 
    With Range("B6:N" & lr)
        .HorizontalAlignment = xlGeneral
        .Font.Size = 16
    End With
    
    For i = 6 To lr
                    With Range("b" & i)
                        On Error Resume Next
                         t = Application.WorksheetFunction.Match(Range("b" & i), Range("p1:p4"), 0)
                         If t Then .Font.Size = 24: .Resize(1, 13).HorizontalAlignment = xlCenterAcrossSelection
                    End With
             t = 0
            On Error GoTo 0
    Next
    Application.ScreenUpdating = True
  End Sub

 

[ابو حمادة]

شكرا ليك اخي الغالي الكود يعمل بكفاءه عاليه ولكن فيه مشكله وجهتني وهي ان عند تطبيق الكود علي المستند الاصلي لا يعمل الكود بسبب  ان الخلايه فيه دالة انبوكس 

هل هناك حل لتفادي هذه المشكله