تلوين رؤس الاعمده عند الوقوف علي اي خليه بها

[طاهر محمد]

السلام عليكم ورحمة الله وبركاته

برجاء عمل كود يلون رؤس الاعمده فقط عند الوقوف علي اي خليه بها

بمعني عندما نكتب في عمود المرتبات يظلل كلمة مرتبات فء رأس العمود

لانني يحدث معي لبس في اختيار الاعمده لو كانت كثيره

ولكم جزيل الشكر

تظليل.zip

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

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

Option Explicit


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim C%, R%
Dim My_Rg As Range
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 C = ActiveSheet.Cells(3, Columns.Count).End(1).Column
 R = ActiveSheet.Cells(Rows.Count, 1).End(3).Row + 2
 Set My_Rg = Range("a3").Resize(R - 2, C)
 If Intersect(Target, My_Rg) Is Nothing Then GoTo 1
  My_Rg.Interior.ColorIndex = 0
  My_Rg.Columns(Target.Column).Interior.ColorIndex = 36
1:
Application.EnableEvents = True
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

الملف مرفق

تظليل salim.rar

[طاهر محمد]

 

 

 شكرا جزيلا  ا/ سليم حاصبيا

الكود  لايعمل يعطي رسالة  ولايعمل

برجاء تظليل رأٍس العمود وليس العمود بالكامل

ولكم جزيل الشكر

 

 

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

تم تعديل الكود

(يجب وضعه في حذث الصفحة و ليس في موديل مستقل)

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim C%, My_Rg As Range
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 C = ActiveSheet.Cells(3, Columns.Count).End(1).Column
 Set My_Rg = Range("a3").Resize(500, C)
 If Intersect(Target, My_Rg) Is Nothing Then GoTo 1
My_Rg.Rows(1).Interior.ColorIndex = 0
 Cells(3, Target.Column).Interior.ColorIndex = 36
1:
Application.EnableEvents = True
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

الملف مرفق

 

Talween.rar

[طاهر محمد]

تم - شكرا جزيلا