Foksh

متابع بصمت

وعليكم السلام ورحمة الله وبركاته ... الأصل أخي @ahmed_dz ، أن توضح طلبك بأكثر مما قمت به .. فمثلاً :- هل تريد الاحتساب ليكون للفترة بين G2-G3 مع استثناء الفترة التي بين C4-F4 ( العطلتين ) . والأمر نفسه للفترة بين H2-H3 !!!! أم ماذا ؟؟؟ يرجى توضيح مطلبك بحرص أكثر حتى تجد إجابة شافية وسريعة .

تجربة بسيطة حقيقية على ملف ACCDE .😎.

هههههههه ، يا عيني عليك ، اكتشفتها بنفسك .. جرب التعديل الأخير على أكثر من احتمال :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape, c As Range Dim r As Long, i As Long, n As Long Dim usedRows As Collection Dim dayCount As Long, perDay As Long, extra As Long Dim rr As Variant, lastCol As Long Dim hasLesson As Boolean Dim lessonCount As Long Dim circlesThisDay As Long If x <= 0 Then Exit Sub Set usedRows = New Collection lessonCount = 0 For r = startRow To endRow hasLesson = False For i = 3 To 10 If Cells(r, i).Value <> "" Then hasLesson = True lessonCount = lessonCount + 1 End If Next i If hasLesson Then usedRows.Add r Next r dayCount = usedRows.Count If dayCount = 0 Then Exit Sub n = 0 If x = lessonCount Then For r = startRow To endRow For i = 10 To 3 Step -1 If Cells(r, i).Value <> "" Then Set c = Cells(r, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 n = n + 1 If n = x Then Exit Sub End If Next i Next r ElseIf x > lessonCount Then Do While n < x For r = startRow To endRow For i = 10 To 3 Step -1 If Cells(r, i).Value <> "" Then Set c = Cells(r, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 n = n + 1 If n = x Then Exit Sub End If Next i Next r Loop Else perDay = x \ dayCount extra = x Mod dayCount If x > 10 And x < lessonCount Then extra = extra + 1 For Each rr In usedRows circlesThisDay = perDay If extra > 0 Then circlesThisDay = circlesThisDay + 1 extra = extra - 1 End If lastCol = 0 For i = 10 To 3 Step -1 If Cells(rr, i).Value <> "" Then lastCol = i Exit For End If Next i For i = lastCol To 3 Step -1 If Cells(rr, i).Value <> "" And circlesThisDay > 0 Then Set c = Cells(rr, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 circlesThisDay = circlesThisDay - 1 n = n + 1 If n = x Then Exit Sub End If Next i Next rr End If End Sub

أنصحك أخي @بلانك ، بتجربة إحتمالات كثيرة على النتيجة والتحقق منها 100% 😉

علني اكون قد فهمت المنطق جيداً .. تفضل التعديل :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape Dim r As Long, i As Long, n As Long Dim c As Range Dim usedRows As Collection Dim dayCount As Long, perDay As Long, extra As Long Dim rr As Variant, lastCol As Long Dim hasLesson As Boolean If x <= 0 Then Exit Sub Set usedRows = New Collection For r = startRow To endRow hasLesson = False For i = 3 To 10 If Cells(r, i).Value <> "" Then hasLesson = True Exit For End If Next i If hasLesson Then usedRows.Add r Next r dayCount = usedRows.Count If dayCount = 0 Then Exit Sub perDay = x \ dayCount extra = x Mod dayCount n = 0 For Each rr In usedRows Dim circlesThisDay As Long circlesThisDay = perDay If extra > 0 Then circlesThisDay = circlesThisDay + 1 extra = extra - 1 End If lastCol = 0 For i = 10 To 3 Step -1 If Cells(rr, i).Value <> "" Then lastCol = i Exit For End If Next i For i = lastCol To 3 Step -1 If Cells(rr, i).Value <> "" And circlesThisDay > 0 Then Set c = Cells(rr, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _ c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 circlesThisDay = circlesThisDay - 1 n = n + 1 If n >= x Then Exit Sub End If Next i Next rr End Sub

لم افهم بالضبط !!!! يعني النتيجة المطلوبة ، أنه حتى يوم الاربعاء الحصة 2-3 تكون عليها دائرة ؟؟؟ بدلاً من الحصة الخامسة ليوم الإثنين !!!

تمام .. استبدل الدالة الرئيسية بالتالية ، وجربها على ملفك بعد إزالة الدوائر السابقة طبعاً :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape Dim i As Long, r As Long, n As Long Dim c As Range If x <= 0 Then Exit Sub i = 10 n = 0 Do While i >= 2 For r = endRow To startRow Step -1 Set c = Cells(r, i) If c.Value <> "" Then Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _ c.Left, c.Top, c.Width, c.Height) n = n + 1 Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 If n >= x Then Exit Sub End If Next r i = i - 1 Loop End Sub

وعليكم السلام ورحمة الله وبركاته .. على حسب ما فهمت أن المقصود هو أكواد رسم الدوائر كما في ملفك المرفق ، صحيح ؟؟ طيب بدايةً .. وللتوضيح :- إذا كانت الأعمدة تتغير ( ليس دائماً العمود 10 ) ، هنا أخي بلانك يمكنك إضافة معامل رابع للدالة DrawCircles لتحديد آخر عمود ، أو استخدام نطاق أكثر حيوية . لكن بناءً على الأكواد الحالية من ملفك المرفق ، أعتقد أن i = 10 و i >= 2 متغيران ثابتان لجميع الحالات . صحيح ؟؟ إذا كان ما فهمته صحيح .. فاستعمل ما يلي :- الدالة الرئيسية :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape Dim i As Long, s As Long, n As Long Dim c As Range If x <= 0 Then Exit Sub i = 10 n = 0 Do While i >= 2 For Each c In Range(Cells(startRow, i), Cells(endRow, i)) If c.Value <> "" Then Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _ c.Left, c.Top, c.Width, c.Height) n = n + 1 Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 If n >= x Then Exit Sub End If Next c i = i - 1 Loop End Sub ثم تستدعيها من خلال الزر وبتمرير المجموعات التي تريدها ولك الحرية في ذلك ، بهذا النمط :- Sub AddCirclesMain() Call DrawCirclesByFoksh(Range("n9").Value, 10, 14) Call DrawCirclesByFoksh(Range("n17").Value, 18, 22) Call DrawCirclesByFoksh(Range("n25").Value, 26, 30) End Sub طبعاً ستستدعي الدالة AddCirclesMain في زر رسم الدوائر .

وعليكم السلام ورحمة الله وبركاته .. جري استخراج القيم من الخليتين كنص . في أي خلية تريدها استخدم المعادلة التالية :- =TEXT(C3,"yyyy/mm/dd") & " " & TEXT(B3,"yyyy/mm/dd")

حاول تغيير اسم الخط الذي تستخدمه لتنسيق هذا العنصر 🤔

أخي بلانك .. لإجراءاتكم بنقل الإجابة إلى الحل الأخير . ما لم يكن هناك أي تعديل آخر .

أراك قد عدت الى استعمال الساعة في برامجك أخي جعفر .. رغم مقولتك :- وهنا أراك تبحث عن ثغرة برأس الإبرة .😉. علك قد تجد حلاً في يوم من الأيام .. لأن الفكرة التي نفذناها نفذت خصيصاً لكي تغنيك عن طريقة =Now() وفكرة التايمر الميتة التي طرحتها وتشتكي منها أصلاً ! بالتوفيق 😇

مبارك عليك الحل .. وعذراً لعدم المتابعة معك في وقتها ، بس كنت خارج من الشغل للأسف .. في المرفق اللي رفعتهولك ، كان فعلاً يتم التنفيذ على الإمتدادين MDB و ACCDB من إصدارات 2007 وما فوق .. لكنك بحثت عن فكرة زرين لكل وظيفة ، وهذا كان يسيراً جداً من خلال الفكرة اللي طرحتها .. ولكن كل الطرق تؤدي إلى روما - ما دامت روما قريبة - .. وفعلاً نسختك اللي رفعتها ما اشتغلتش عندي أنا كمان وده اللي خلاني أطلع وقلت بجرب على كمبيوتر تاني .. 👍🏻

أصغر همومك أخي أحمد .. كمثال ؛ في حدث بعد التحديث للعنصر OptMain ، جرب الفكرة التالية أو كما تريد لحاجتك :- Private Sub OptMain_AfterUpdate() If Me.OptMain.Value = 1 Then Me.Btn_Doit.Caption = "إلغاء تفعيل مفتاح الشيفت" Else Me.Btn_Doit.Caption = "تفعيل مفتاح الشيفت" End If End Sub