عمل تنسيقات شرطية لبيانات جدول طبقاً لجدول أخر

MOSTACHARHN · أكتوبر 6, 2020

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

عنوان مخالف ... تم تعديل عنوان المشاركة ليعبر عن طلبك

ادراج جدول بناء على بيانات في جدول آخر.xlsx

**سليم حاصبيا** · أكتوبر 7, 2020

جرب هذا الملف الصفحة Master (و لا حاجة لهذا الكم الهائل من التنسيق الشرطي)

Option Explicit
Dim m%, x%, t%, k%
Dim cel As Range
'++++++++++++++++++++++
Sub fil_data()
Empty_cel
test_vertical
test_Horizontal
End Sub
'+++++++++++++++++++++++++++++++
Sub Empty_cel()
Dim ro%, col%
Dim ar_col()
Dim Clr%, Rg As Range
ro = Cells(Rows.Count, "F").End(3).Row
 If ro < 9 Then ro = 9
 Cells(9, "F").Resize(ro, 2).ClearContents
col = Cells(8, Columns.Count).End(1).Column
If col < 8 Then col = 8
Cells(8, 8).Resize(, col - 10).ClearContents
 For Each Rg In Range("Mawad").Columns(1).Cells
 
  Select Case Rg.Value
   Case "عربية": Clr = 4
   Case "إسلامية": Clr = 6
   Case "رياضيات": Clr = 20
   Case "فرنسية": Clr = 38
   Case "إنجليزية": Clr = 40
   Case Else: Clr = xlNone
  End Select
 Rg.Resize(, 2).Interior.ColorIndex = Clr
 Next
 '++++++++++++++++++++++++++++
 For Each Rg In Range("Mustwa").Columns(1).Cells
 
  Select Case Rg.Value
   Case "4م": Clr = 4
   Case "3م": Clr = 6
   Case "2م": Clr = 20
   Case "1م": Clr = 38
   Case Else: Clr = xlNone
  End Select
 Rg.Resize(, 2).Interior.ColorIndex = Clr
 Next
 
 
End Sub
'++++++++++++++++++++++++++++
Sub test_vertical()
x = 9
m = Range("Mawad").Rows.Count
For Each cel In Range("Mawad").Columns(1).Cells
 Cells(x, "F").Resize(cel.Offset(, 1)).Value = _
 cel
 For k = 1 To cel.Offset(, 1)
 Cells(x, "F").Offset(, 1).Offset(k - 1) = _
 cel & " : " & k
 Next
 Cells(x, "F").Resize(cel.Offset(, 1), 2) _
 .Interior.ColorIndex = cel.Interior.ColorIndex
 x = x + cel.Offset(, 1)
Next
End Sub
'+++++++++++++++++++++
Sub test_Horizontal()

x = 8: t = 8
m = Range("Mustwa").Rows.Count
For Each cel In Range("Mustwa").Columns(1).Cells
 For k = 1 To cel.Offset(, 1)
 Cells(x, t).Offset(, k - 1) = cel & " : " & k
 Next
 Cells(x, t).Resize(, cel.Offset(, 1)).Interior.ColorIndex = _
 cel.Interior.ColorIndex
 
 t = t + cel.Offset(, 1)
Next
End Sub
'++++++++++++++++++++++++++++

الملف مرفق

MOSTACHAR.xlsm