علي بطيخ سالم

تطبيق هذا الكود على نفس الملف 

Option Explicit
Sub copy_as_you_want()
Dim i, c As Integer
Dim Cont
Dim Lr As Long
Lr = ActiveSheet.Cells(Rows.count, 3).End(3).Row

Range("c3:c" & Lr).ClearContents
i = 3
c = 3

  Do While Cells(i, 1) <> ""
    Cont = Cells(i, 1).Offset(0, 1).Value
        If Not IsNumeric(Cont) Or Cont = "" Or Cont = 0 Then i = i + 1: GoTo 1
        Cont = Int(Abs(Cont))
     Range("c" & c & ":c" & c + Cont - 1).Value = Cells(i, 1).Value
    i = i + 1
    c = c + Cont
1:
  Loop
End Sub

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

الملف الأصلي.xlsx

هذه الدالة حاولت تطبيقها على هذا الملف لكن لم تعمل معي 

=IF(ROWS($O$3:O3)>SUM(N:N);"";INDEX($M$3:$M$200;MATCH(FALSE; COUNTIF($O$2:O2;$M$3:$M$200)= $B$3:$B$200;0)))

استاذ سليم.xlsx

في ٧‏/٦‏/٢٠١٧ at 16:29, سليم حاصبيا said:

زيادة في اثراء الموضوع هذا الكود

 

Option Explicit
Sub copy_as_you_want()
Dim i, c As Integer
Dim Cont
Dim Lr As Long
Lr = ActiveSheet.Cells(Rows.count, 3).End(3).Row

Range("c3:c" & Lr).ClearContents
i = 3
c = 3

  Do While Cells(i, 1) <> ""
    Cont = Cells(i, 1).Offset(0, 1).Value
        If Not IsNumeric(Cont) Or Cont = "" Or Cont = 0 Then i = i + 1: GoTo 1
        Cont = Int(Abs(Cont))
     Range("c" & c & ":c" & c + Cont - 1).Value = Cells(i, 1).Value
    i = i + 1
    c = c + Cont
1:
  Loop
End Sub

 

ممكن أستاذ سليم تنفذه على الملف الخاص بي بارك الله فيك

ارجوا التعديل.xlsx

الحمد لله وجدت الحل في مشاركة سابقة لك استاذ سليم وبارك الله لك وجزاك الله خيراً 

50 دقائق مضت, سليم حاصبيا said:

 

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

ارجوا التعديل.xlsx

22 دقائق مضت, سليم حاصبيا said:

تم معالجة الامر

 

تالرقم.xlsx

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

9 دقائق مضت, سليم حاصبيا said:

تم معالجة الامر

 

تالرقم.xlsx

جزاك الله خيراً استاذنا لكن هناك خطأ ما لا أدري ما هو بالتحديد فعندما غيرت قيمة الرقم في الخلية D والتي تمثل عدد الفصل 1-1 أعطى هذا الخطأ كما أن التوزيع لا يتم بصورة سليمة فأنا أريد أن يقوم بتوزيع الفصول حسب الأعداد الموضحة في ذلك النطاق وأرجوا أن يمتد التحديد أكثر من ذلك ليتسع على الأقل 300 أسم فهذا مثال أريد أن أطبقه جزاك الله خيراً 

في الملف المرفق بيان ما أحتاج وهو توزيع رقم على مجموعة خلايا في عمود معين

توزيع الرقم.xlsx

السلام عليكم ورحمة الله وبركاته : طلبي هو هل هناك كود أو دالة أو معادلة تسمح لملف الإكسل بزيادة أو نقصان الصفوف أو الأعمدة حسب عدد الطلاب مثلاً يعني في لو عندي 100 طالب وأريد توزيعهم مرة على 3 فصول ومرة أخرى على 4 فصول طبعاً في كل مرة سوف يزيد عدد الطلاب في كل فصل أو ينقص حسب التوزيع .. والمطلوب هو دالة أو شئ من هذا القبيل تسمح لي بزيادة الصفوف أو نقصانها حسب العدد المرحل بها وجزاكم الله خيراً ... 

المصنف1.xlsx

ما شاء الله كود ممتاز أستاذنا الاستاذ سليم وجزاك الله خيراً استاذنا... لكن هل من شرح بسيط لو أحببت أن أغير من هذه البيانات لبيانات أخرى كيف أنفذها من خلال هذا الكود جزاك الله خيراً

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

الله أكبر ما شاء الله عليكم والله مش عارف أرد جميلكم كيف ولا أملك سوى الدعاء لكم بالتوفيق والبركة الدائمة الله آمين جزاكم الله خيراً استاذ علي جزاكم الله خيراً استاذ سليم

جزاك الله خيراً استاذ علي ... لكن هل من شرح بسيط لو أحببت أن أغير من هذه البيانات لبيانات أخرى كيف أنفذها من خلال طريقتك جزاك الله خيراً

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

سداد المصروفات.xls

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

ممتاز ..... ما شاء الله

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

شكراً لك

هل من مساعدة ؟؟؟؟؟؟؟؟؟

لماذا يتم تجاهل المشاركة الخاصة بي أرجوا المساعدة إخواني وأحبابي؟؟؟؟؟؟؟؟؟

أرجوا مساعدتي في تنفيذ المطلوب في هذا الشيت بارك الله فيكم وهو ترحيل بيانات من صفحة إلى صفحة أخرى في الصفوف الفردية وترك الصفوف الزوجية على أن تكون البيانات المرحلة بالنسبة للدرجات في الأعمدة المظللة باللون الأصفر

قالب نتيجة الدور الثاني.rar

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

Sub Circles()
'åÐÇ ÇáßæÏ ááãÍÊÑã ÇáäÇÈÛå ÒíÒæ ÇáÚÌæÒ
'ÇáåÏÝ ãä ÇáßæÏ åæ æÖÚ ÏæÇÆÑ Úáì ÏÑÌÇÊ  Ýí ÇÚãÏå ãÚíäå
'Êã åÐÇ ÇáßæÏ Ýí 19/5/2017

'ÇÓÊÏÚÇÁ ßæÏ ÇáãÓÍ ÇæáÇ
Call DeletingShp

'ãÊÛíÑÇÊ
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range

'ÇÓã ÕÝÍå ÇáÚãá
Set ws = Sheets("ÔíÊ")

  ' åÐÇ ÔÑØ ÇáÇ íÚãá ÇáßæÏ ÞÈá ÇáÕÝ 14
If LR < 14 Then LR = 14

'ãÊÛíÑ áÚÏ ÇáÕÝæÝ
LR = ws.Range("C" & Rows.Count).End(xlUp).Row

'ÇÑÞÇã ÇáÇÚãÏå ÇáãØáæÈ æÖÚ ÏæÇÆÑ ÝíåÇ
Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)

'ÈÏÇíå ÇáÕÝæÝ
For R = 14 To LR

  ' ÚÑÖ ÇáãÕÝæÝÉ ÇáÎÇÕÉ ÈÇáÇÚãÏÉ
For i = LBound(Arr) To UBound(Arr)

  ' äØÇÞ ÊØÈíÞ ÇáÇãÑ æåæ ÇáÎÇÕ ÈÑÓã ÇáÏæÇÆÑ
For Each Cel In ws.Cells(R, Arr(i))

  '  ÇáÔÑØ ÇáÐì Úáì ÇÓÇÓå ÓæÝ íÊã ÑÓã ÇáÏæÇÆÑ
If Cel.Value < ws.Cells(4, Cel.Column) Or Cel.Value = "Û" Then

  ' ãæÇÕÝÇÊ ÇáÔßá æåæ åäÇ ÚÈÇÑÉ Úä ÏÇÆÑÉ æãÇ Èíä ÇáÇÞæÇÓ åæ ÇÈÚÇÏ ÇáÏÇÆÑÉ ÍÊì áÇ ÊÕÈÍ ÇßÈÑ ãä ÍÌã ÇáÎáíÉ
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)

  ' ãæÇÕÝÇÊ ÇáÏÇÆÑÉ ãä ÍíË ÏÑÌÉ Çááæä æÍÌã ÇáÎØ æ ÇáÔÝÇÝíÉ
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

  '    ÇáßæÏ ÇáËÇäì
Sub DeletingShp()

   ''  ÇáãÊÛíÑÇÊ
    Dim shp As Shape, x As Long
    
     ' åÐÇ ÇáäØÇÞ íÓãÍ ÈãÓÍ ßá ÇáÇÔßÇá Ýì æÑÞÉ ÇáÚãá ÓæÇÁ ÏÇÆÑÉ Çæ ÛíÑåÇ
    For Each shp In ActiveSheet.Shapes
    
   '   ÇãÑ ÇáãÓÍ
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
   '    ÑÓÇáÉ ÈÚÏÏ ÇáÏæÇÆÑ ÇáÊì Êã ãÓÍåÇ
'MsgBox "Êã ÍÐÝ   " & x & "   ÏÇÆÑÉ ÈäÌÇÍ", vbMsgBoxRight, "ÇáÍãÏááå"
End Sub

أرجوا أن يجيبني أحد

شكراً لك استاذ سليم لكن أنا قمت بعمل شرط في الملف ويحتوي العمود q

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

للتعديل.xls

في ٣٠‏/٧‏/٢٠١٨ at 03:17, ahmedkamelelsayed0 said:

وجود خلية فارغة تحستب ناجح تحدث خلل في المعادلات

هل من الممكن وضعها كصفر مختفي بحيث يمكن اخفاءه واعتبار هذا الصفر درجة للنجاح (لأن باقي الدرجات يشترط فيها ألا تقل عن عشرة درجات) وإن لم يمكن اخفاؤه يترك صفراً كما هو بحيث أستطيع اعطاءه لون أبيض فيصبح كأن الخلية فارغة لكن هو في الأساس بها صفر

في الملف المرفق المطلوب بالتحديد

Book1.xls

أو إن أمكن إضافة دالة ناجح وراسب في الخلية CS16 بدلالة الدرجات في الخلايا O16 و X16 و AG16 و AR16 و BC16 و BX16 و CI16 و  CR16 وإن كانت خلية فارغة من هذه الخلايا يعتبر التلميذ ناجح في هذه المادة وتطبق نفس الدالة =IF(OR(BX16<10;BX16="غ");1;0) بحيث إن كان حاصل على أقل من 10 درجات أو غ يعني غائب في هذه المادة تطبق نفس الشروط الأربعة المذكورة 

طيب حتى محتاج دالة ناجح أو راسب في خلية النتيجة بأبسط ما يكون باعتبار الدرجات التي في مقابلها فقط ولو كان الطالب غائب يعتبر راسب ولو كانت الخلية فارغة بدون أرقام أي درجات يعتبر ناجح في المادة بارك الله فيكم