أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
محمدعبدالسلام لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة طلب مساعدة اريد في كل 4 من شهر يتم نسح الاسم من عمود الى عمود اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





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

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


موضوع مغلق


06-10-2020 10:57 مساء
mostachar
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 17-10-2019
رقم العضوية : 15241
المشاركات : 33
الجنس : ذكر
تاريخ الميلاد : 1-1-1979
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 36
 offline 

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

 
  ادراج جدول بناء على بيانات في جدول آخر.jpg   تحميل jpg ادراج جدول بناء على بيانات في جدول آخر.jpg مرات التحميل :(2)
الحجم :(152.473) KB
 
  ادراج جدول بناء على بيانات في جدول آخر.xlsx   تحميل xlsx مرات التحميل :(0)
الحجم :(13.363) KB



أفضل إجابة مقدمة من salim وهي:
تم معالجة الأمر
1- اذا ادخلت نصاً او رقم أقل  أو يساوي صفر يتجاهل الماكرو ذلك ولا يدرج المادة
2- اذا ادخلت بالخطأ رقماً أكبر من 3 يقوم الماكرو بتغييره الى 3
3- اذا ادخلت رقماً عشرياً (مع فاصلة) يقوم الماكرو بادراج الرقم الصحيح
الماكرو الجديد

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).Clear
col = Cells(8, Columns.Count).End(1).Column
If col < 8 Then col = 8
Cells(8, 8).Resize(, col - 10).Clear
 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()
Dim P%
x = 9
m = Range("Mawad").Rows.Count
For Each cel In Range("Mawad").Columns(1).Cells
 If Val(cel.Offset(, 1)) <= 0 Then GoTo Next_cel
  cel.Offset(, 1) = Int(cel.Offset(, 1))
  If cel.Offset(, 1) > 3 Then cel.Offset(, 1) = 3
 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_cel:
Next
P = Cells(Rows.Count, "F").End(3).Row
If P < 9 Then Exit Sub
 With Range("F9").Resize(P - 8, 2)
  .InsertIndent 1
  .Borders.LineStyle = 1
  .Font.Size = 20
  .Font.Bold = True
 End With

End Sub
'+++++++++++++++++++++
Sub test_Horizontal()

x = 8: t = 8
m = Range("Mustwa").Rows.Count
For Each cel In Range("Mustwa").Columns(1).Cells
If Val(cel.Offset(, 1)) <= 0 Then GoTo Next_cel
 cel.Offset(, 1) = Int(cel.Offset(, 1))
 If cel.Offset(, 1) > 3 Then cel.Offset(, 1) = 3
 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_cel:
Next
 With Range("F8").CurrentRegion.Rows(2)

  .InsertIndent 1
  .Borders.LineStyle = 1
  .Font.Size = 20
  .Font.Bold = True
.Cells(1, 1).Resize(, 2).HorizontalAlignment = 3
  End With
End Sub
'++++++++++++++++++++++++++++


الملف من جديد
عرض الإجابة




07-10-2020 07:15 صباحا
مشاهدة مشاركة منفردة [1]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif عمل تنسيقات شرطية لبيانات جدول طبقاً لجدول أخر
وعليكم السلام ورحمه الله وبركاته
تفضل بفضل الله الحل ان شاء الله
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
والرجاء تعديل عنوان المشاركة ليصبح ادراج بيانات في صفوف بناء على بيانات اخرى
فالموضوع ليس المطلوب منه تنسيقات
 
 
  ادراج جدول بناء على بيانات في جدول آخر.xlsb   تحميل xlsb مرات التحميل :(6)
الحجم :(18.203) KB


07-10-2020 08:55 صباحا
مشاهدة مشاركة منفردة [2]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif عمل تنسيقات شرطية لبيانات جدول طبقاً لجدول أخر
جرب هذا الملف   (و لا حاجة لهذا الكم الهائل من التنسيق الشرطي)

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   تحميل xlsm مرات التحميل :(7)
الحجم :(37.274) KB


07-10-2020 09:54 مساء
مشاهدة مشاركة منفردة [3]
mostachar
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 17-10-2019
رقم العضوية : 15241
المشاركات : 33
الجنس : ذكر
تاريخ الميلاد : 1-1-1979
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 36
 offline 
look/images/icons/i1.gif عمل تنسيقات شرطية لبيانات جدول طبقاً لجدول أخر
اليكم رسالة الخطأ بعد حجز العلامة    0

 





 
  خطأ ادراج جدول بناء على بيانات في جدول آخر.jpg   تحميل jpg خطأ ادراج جدول بناء على بيانات في جدول آخر.jpg مرات التحميل :(1)
الحجم :(127.039) KB
 
  بعد و ضع الكود.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(27.069) KB


07-10-2020 11:16 مساء
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif عمل تنسيقات شرطية لبيانات جدول طبقاً لجدول أخر
تم معالجة الأمر
1- اذا ادخلت نصاً او رقم أقل  أو يساوي صفر يتجاهل الماكرو ذلك ولا يدرج المادة
2- اذا ادخلت بالخطأ رقماً أكبر من 3 يقوم الماكرو بتغييره الى 3
3- اذا ادخلت رقماً عشرياً (مع فاصلة) يقوم الماكرو بادراج الرقم الصحيح
الماكرو الجديد

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).Clear
col = Cells(8, Columns.Count).End(1).Column
If col < 8 Then col = 8
Cells(8, 8).Resize(, col - 10).Clear
 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()
Dim P%
x = 9
m = Range("Mawad").Rows.Count
For Each cel In Range("Mawad").Columns(1).Cells
 If Val(cel.Offset(, 1)) <= 0 Then GoTo Next_cel
  cel.Offset(, 1) = Int(cel.Offset(, 1))
  If cel.Offset(, 1) > 3 Then cel.Offset(, 1) = 3
 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_cel:
Next
P = Cells(Rows.Count, "F").End(3).Row
If P < 9 Then Exit Sub
 With Range("F9").Resize(P - 8, 2)
  .InsertIndent 1
  .Borders.LineStyle = 1
  .Font.Size = 20
  .Font.Bold = True
 End With

End Sub
'+++++++++++++++++++++
Sub test_Horizontal()

x = 8: t = 8
m = Range("Mustwa").Rows.Count
For Each cel In Range("Mustwa").Columns(1).Cells
If Val(cel.Offset(, 1)) <= 0 Then GoTo Next_cel
 cel.Offset(, 1) = Int(cel.Offset(, 1))
 If cel.Offset(, 1) > 3 Then cel.Offset(, 1) = 3
 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_cel:
Next
 With Range("F8").CurrentRegion.Rows(2)

  .InsertIndent 1
  .Borders.LineStyle = 1
  .Font.Size = 20
  .Font.Bold = True
.Cells(1, 1).Resize(, 2).HorizontalAlignment = 3
  End With
End Sub
'++++++++++++++++++++++++++++


الملف من جديد
 
 
  MOSTACHAR_Super.xlsm   تحميل xlsm مرات التحميل :(1)
الحجم :(40.584) KB


09-10-2020 12:34 صباحا
مشاهدة مشاركة منفردة [5]
mostachar
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 17-10-2019
رقم العضوية : 15241
المشاركات : 33
الجنس : ذكر
تاريخ الميلاد : 1-1-1979
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 36
 offline 
look/images/icons/i1.gif عمل تنسيقات شرطية لبيانات جدول طبقاً لجدول أخر
شكراا كثيراا كثيراا .. فعلا انه سحر الاكسل




الكلمات الدلالية
ادراج ، جدول ، بناء ، بيانات ، جدول ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:04 مساء