عبدالله بشير عبدالله

السلام عليكم بعد اذن استاذنا ابو مروان اليك تعديل زر الترحيل باستخدام المصفوفات Sub AddEmployee() Dim ws1 As Worksheet, ws2 As Worksheet Dim nextRow As Long, i As Long Dim srcRange As Variant Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") If ws1.Range("I9").Value = "" Then MsgBox "يرجى إدخال اسم الموظف!", vbExclamation, "تنبيه" Exit Sub End If nextRow = ws2.Cells(ws2.Rows.Count, "C").End(xlUp).Row + 1 srcRange = Array("I5", "I7", "I9", "I11", "I13", "L11", "L13", "I15", "L15", _ "L5", "L7", "L9", "I19", "L19", "I21", "L21", "I23", "L23", _ "I25", "L25", "I28", "L28", "L30", "I33", "L33", "I35", "L35", _ "I37", "I40", "L40", "I44", "L44", "I46", "L46", "I48", "L48", _ "I50", "L50", "I52", "L52", "L55") For i = LBound(srcRange) To UBound(srcRange) ws2.Cells(nextRow, i + 1).Value = ws1.Range(srcRange(i)).Value Next i MsgBox "تمت إضافة الموظف بنجاح!", vbInformation, "نجاح" End Sub بسم الله.xlsm

حرب التعديل التالي توزيع عدد الحصص (233) (1).xlsm

استبدل الكود التالي بالكود بالملف Sub DrawCircles1() Application.ScreenUpdating = False Call DelShap Call ProcessTable(10, 14, 3, 10, "N9") Call ProcessTable(18, 22, 3, 10, "N17") Application.ScreenUpdating = True End Sub Sub ProcessTable(SROW As Long, EROW As Long, SCOL As Long, ECOL As Long, RefCell As String) Dim ws As Worksheet Dim i As Long, j As Long Dim totalCells As Long, totalRequired As Long Dim dayCells As Long, n As Long Dim arrCells() As Long Dim temp() As Double Dim remainder As Long Set ws = ActiveSheet totalRequired = Val(ws.Range(RefCell).Value) totalCells = 0 ReDim arrCells(SROW To EROW) ReDim temp(SROW To EROW) For i = SROW To EROW dayCells = 0 For j = SCOL To ECOL If Trim(ws.Cells(i, j).Value) <> "" Then dayCells = dayCells + 1 End If Next j arrCells(i) = dayCells totalCells = totalCells + dayCells Next i If totalCells = 0 Then Exit Sub For i = SROW To EROW If arrCells(i) > 0 Then temp(i) = totalRequired * arrCells(i) / totalCells Else temp(i) = 0 End If Next i For i = SROW To EROW n = Int(temp(i)) If n > arrCells(i) Then n = arrCells(i) If n = 0 Then ws.Range("M" & i).Value = "" Else ws.Range("M" & i).Value = n End If Next i remainder = totalRequired - Application.WorksheetFunction.Sum(ws.Range("M" & SROW & ":M" & EROW)) Do While remainder > 0 Dim maxI As Long, maxVal As Double maxVal = -1 For i = SROW To EROW If arrCells(i) > Val(ws.Range("M" & i).Value) Then If temp(i) - Int(temp(i)) > maxVal Then maxVal = temp(i) - Int(temp(i)) maxI = i End If End If Next i If ws.Range("M" & maxI).Value = "" Then ws.Range("M" & maxI).Value = 1 Else ws.Range("M" & maxI).Value = ws.Range("M" & maxI).Value + 1 End If remainder = remainder - 1 Loop For i = SROW To EROW n = Val(ws.Range("M" & i).Value) If n > 0 Then Dim validCols() As Long Dim countCols As Long countCols = 0 For j = SCOL To ECOL If Trim(ws.Cells(i, j).Value) <> "" Then countCols = countCols + 1 ReDim Preserve validCols(1 To countCols) validCols(countCols) = j End If Next j Dim k As Long For k = countCols To 1 Step -1 If n = 0 Then Exit For j = validCols(k) With ws.Shapes.AddShape(msoShapeOval, _ ws.Cells(i, j).Left + 5, _ ws.Cells(i, j).Top + 5, _ ws.Cells(i, j).Width - 10, _ ws.Cells(i, j).Height - 10) .Line.Weight = 2 .Fill.Visible = msoFalse End With n = n - 1 Next k End If Next i End Sub

لديك الحق استبدل في الكود wsSource.Range("A4:I4").ClearContents الى wsSource.Range("A7:I7").ClearContents بمعنى الرقم 4 غيره الى 7 فقط

وعليكم السلام نعم اعلم ان هناك طلب ثاني وكان ردي السابق لطلبك الاول اليك الملف وبه طلبك الثاني Plateform19840019.xlsb

وعليكم السلام ورحمة الله وبركاته الحل قم بتحديث اوفيس2007 الى 2010 او احدث فالامر بسيط عند اول محل كمبيوتر اما بالنسبة لطلبك الاول تعديل كود الترحيل اليك الملف Plateform19840019.xlsb

جرب التعديل التالي توزيع عدد الحصص (233) (1).xlsm

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

التوزيع بالكود مغ زر رسم الدوائر توزيع عدد الحصص (233) (1).xlsm

استبدل المعادلة الاولى بالثانية في M10 واسحب لاسفل =IF(COUNTIF(C10:J10;"*")>0;1;0) =IF(SUMPRODUCT(--(C10:J10<>""))>0;1;0)

السلام عليكم بالرغم عدم استيعابي للامر جيدا اليك المحاولة حيث تم ادراج معادلات في عمود مساعد في العمود l وذلك لمعرفة الايام التي ليس بها حصص كذلك تم تعديل المعادلات يمكن سحبها للاسفل لنفس الجدول بدل كتابة كل خلية معادلة خاصة بها مثال للتوضح والمطلوب - 222.xlsm

عند فتح الشيت اضغظ مباشرة على الزرين في نفس الوقت ولا تحدد اي خلايا او استخدم الكود بالملف 5000_A3.xlsb

وعليكم السلام ورحمة الله وبركاته اضغط على مفتاحي Ctrl + ~ (المفتاح الذي فوق Tab)

وعليكم السلام ورحمة الله وبركاته بالنسبة للاوقات التي خارج الاوقات في M&N لم تحدده وفي اي بصمة تسجل تم ربط المعادلات حسب الاوقات في M&N اكسل1.xlsm

وعليكم السلام ورحمة الله وبركاته جرب التعديل بالملف اكسل.xlsm

السلام عليكم نعم المشكلة من حماية الشيتات اليك التعديل مع اظافة الترقيم التلقائي لرقم التسجيل Plateform (1) .xlsb

اخى العزيز جربت الملف جميع الاكواد تعمل حذف الموظف يعمل-حذف الكل يعمل - معاينة الطباعة يعمل - كلها تعمل لدي بدون اي اخطاء ارفق الملف الذي تظهر به الاخطاء

وعليكم السلام ورحمة الله وبركاته يبدو انك نسيت ارفاق اسم المستخدم وكلمة المرور وهي ليست لي لاني اعلمها من مشاركة في موضوع اخر ولكن لاعضاء المنتدى ليتمكنوا من المشاركة وتقديم الحلول اسم المستخدم سطيف كلمة المرور 19840019 عودة للملف :- رقم التسجيل يجب ان يكون فريدا بمعنى كل موظف له رقم تسجيل خاص به لا يتكرر مع موظف اخر Plateform (1) (2) (1).xlsb

اليك التعديل Plateform (1).xlsb

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

وعليكم السلام ورحمة الله وبركاته كان من المفترض ارفاق ملفك او وضعت الرابط الى موضوعك السابق حتى يتسنى لاعضاء المنتدى المشاركة وهي عملية لها علاقة بالارشفة والتنظيم واتاحة الفرصة لمن يرغب في المشاركة على كل حال رابط الموضوع السابق https://www.officena.net/ib/topic/143408-عند-حماية-الورقة-يظهر-خطأ/ اليك الملف وبه طلبك ان شاء الله Plateform.xlsb

اليك التعديل Plateform.xlsb

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

السلام عليكم تم عمل الاحصائيات الملف المرفق به الاحصاء Plateform3.xlsb الشريط المتحرك ليس لدي جلفية لعملة ولا اراه مهما لانه سيسبب ثقل للملف ا1ذا تحققت طلباتك ارجو فتح موضوع جديد لاي طلب جديد وهذا حسب قوانين المنتدى

اليك التعديل Plateform2.xlsb