كل الانشطه

الف ميروك 💐

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

مسائكم خير وسعادة وافراح ان شاء الله هذا برنامج مرسل واتساب من عمل الأستاذ أبو خليل جزاه الله خير أحتاج اضافة نموذج يكون عمله يرسل لكل اسم صوره مختلفه عن الاسم الثاني sendwatsWebAll.rar

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

مبروك التشريف .. والانضمام الى كوكبة الخبراء .. تستاهل اكثر زادك الله علما .. ووفقك وسددك

للاسف يعطي عند التنفيذ ويمسح ارقام الملاحظين انظر الى الصورتين

مبارك عليك المسمى أخي @Ahmos 🙂 وهو ليس عليك بجديد .. ومبارك علينا انظمامك لهذه القافلة المباركة .. 🌹 جعلك الله عطاء لا ينضب 🙂🤲

عندما يكون العدد كبير يمكن التحكم في الشروط و لكن الواقع غير ذلك فيكون أهم شرط هو التساوي قدر الأمكان أما دخول نفس اللجان فيتم التحكم فيها يدويا . جرب الملف المرفق بعد تعديل الكود كود (1).xlsm

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

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

اولا شكرا على تعبك ولكن غند تنفيذ الكود يعطي خطأ لاحظ الصورة

@شايب شكراً جزيلاً لك أخي الكريم بارك الله فيك أسئلك الدعاء بالتوفيق والسداد فالحمد لله والشكر له علي كل شي { سبحان الله وبحمده سبحان الله العظيم } أشعر اني مازلت هاوي مجتهد وصدقاً أجد فيكم الكثير من المعلمين الأفاضل ولكني سأعتز بهذه الترقية ولو لم أكن أستحقها 😁

السلام عليكم ورحمة الله و بركاته المشكلة الرئيسية في هذه الأكواد التي تستخدم في توزيع الملاحظة هي أنها قد تدخل في حلقة لا نهائية عندما لا يمكن إيجاد حل يلبي جميع الشروط. عندما تفرض شروط صارمة على التوزيع (مثل عدم التكرار أو حد التكرار)، فإن هناك احتمالًا أن يفشل الكود في إيجاد توزيع مناسب — مما يؤدي إلى حلقة لا نهائية تقريبا أو وقت تنفيذ طويل جدًا. فمثلا لجنة ثانوية عامة هذا العام بها 45 لجنة مع حوالي 110 ملاحظ لذلك لابد من التغاضي عن بعض الشروط عند كتابة الكود ثم التدخل يدويا في أضيق الحدود. و مشاركتك السابقة عند طلب برنامج ملاحظة قدمت محاولة ممتازة لأحد الأستاذة تفي بالغرض هي كما ذكرت سابقا لابد من التدخل اليدوي. و ننتظر مشاركات اأساتذة المنتدى في هذا الموضوع. جرب الكود التالي فهو على الأقل يضمن عدم التكرار و يتبقى بعض الخلايا البسيطة الغير موزعة فيمكن توزيعها يدوي. Public Sub Observer222() Dim ws As Worksheet Dim row As Long, col As Long Dim lr1 As Long, lr2 As Long, lc1 As Long, max As Long Dim attempt As Long, totalAttempts As Long Dim randVal As Variant Dim isValid As Boolean Dim availableNames As Variant ' تغيير التعريف هنا Dim i As Long ' إعداد الورقة On Error Resume Next Set ws = Worksheets("Sheet1") On Error GoTo 0 If ws Is Nothing Then MsgBox "لم يتم العثور على الورقة 'Sheet1'!", vbCritical Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' حساب آخر صف في العمود B وC وآخر عمود في الصف 2 lr1 = ws.Cells(ws.Rows.Count, 2).End(xlUp).row lr2 = ws.Cells(ws.Rows.Count, 3).End(xlUp).row lc1 = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ' التحقق من مدى البيانات If lr1 <= 2 Or lr2 <= 2 Or lc1 <= 4 Then MsgBox "مدى البيانات غير صحيح!", vbCritical Application.ScreenUpdating = True Exit Sub End If ' حساب الحد الأقصى للتكرارات لكل اسم max = Application.WorksheetFunction.Ceiling_Math((lc1 - 4) / (lr1 - 2), 1) ' تخزين الأسماء المتاحة في مصفوفة availableNames = ws.Range("B3:B" & lr1).value ' تغيير طريقة تخزين الأسماء totalAttempts = 0 Do While totalAttempts < 5 ' عدد المحاولات الكلية للجدول ' مسح البيانات القديمة ClearOldData ws, lr2, lc1 ' توزيع الأسماء عشوائياً If DistributeNames(ws, lr2, lc1, max, availableNames) Then ' نجحت العملية Exit Do End If totalAttempts = totalAttempts + 1 Loop If totalAttempts >= 5 Then MsgBox "لم يتم العثور على حل بعد عدة محاولات", vbCritical Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If ' تحديث عدد التعيينات لكل اسم UpdateAssignmentCounts ws, lr1, lr2, lc1 ' تظليل الخلايا المتشابهة Call HighlightDuplicates(ws, lr2, lc1) Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم التوزيع بنجاح!", vbInformation End Sub Private Sub ClearOldData(ws As Worksheet, ByVal lr2 As Long, ByVal lc1 As Long) With ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)) .ClearContents .Interior.colorIndex = xlNone End With End Sub Private Function DistributeNames(ws As Worksheet, ByVal lr2 As Long, ByVal lc1 As Long, _ ByVal max As Long, ByVal availableNames As Variant) As Boolean Dim row As Long, col As Long Dim attempt As Long Dim randVal As Variant Dim randIndex As Long Dim namesCount As Long namesCount = UBound(availableNames, 1) For row = 3 To lr2 For col = 4 To lc1 attempt = 0 Do While attempt < 100 ' اختيار اسم عشوائي randIndex = Application.WorksheetFunction.RandBetween(1, namesCount) randVal = availableNames(randIndex, 1) ' التحقق من صحة الوضع If IsValidPlacement(ws, row, col, randVal, max, lr2, lc1) Then ws.Cells(row, col) = randVal Exit Do End If attempt = attempt + 1 Loop If attempt >= 100 Then DistributeNames = False Exit Function End If Next col Next row DistributeNames = True End Function Private Function IsValidPlacement(ws As Worksheet, ByVal row As Long, ByVal col As Long, _ ByVal value As Variant, ByVal max As Long, _ ByVal lr2 As Long, ByVal lc1 As Long) As Boolean ' التحقق من التكرار المجاور If col > 4 Then If ws.Cells(row, col - 1).value = value Then Exit Function End If End If ' التحقق من التكرار الأفقي If Application.CountIf(ws.Range(ws.Cells(row, 4), ws.Cells(row, col - 1)), value) >= max Then Exit Function End If ' التحقق من التكرار الرأسي If Application.CountIf(ws.Range(ws.Cells(3, col), ws.Cells(row - 1, col)), value) > 0 Then Exit Function End If IsValidPlacement = True End Function Private Sub UpdateAssignmentCounts(ws As Worksheet, ByVal lr1 As Long, ByVal lr2 As Long, ByVal lc1 As Long) Dim row As Long For row = 3 To lr1 If Not IsEmpty(ws.Cells(row, 2)) Then ws.Cells(row, 1) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)), ws.Cells(row, 2)) End If Next row End Sub Private Sub HighlightDuplicates(ws As Worksheet, ByVal lr2 As Long, ByVal lc1 As Long) Dim r As Long, c As Long Dim cell As Range, rngRow As Range, rngCol As Range Dim colorDict As Object Dim uniqueValue As Variant Dim colorIndex As Long ' إنشاء قاموس للألوان Set colorDict = CreateObject("Scripting.Dictionary") ' مجموعة من الألوان المختلفة Dim colors(1 To 10) As Long colors(1) = RGB(255, 200, 200) ' أحمر فاتح colors(2) = RGB(200, 255, 200) ' أخضر فاتح colors(3) = RGB(200, 200, 255) ' أزرق فاتح colors(4) = RGB(255, 255, 200) ' أصفر فاتح colors(5) = RGB(255, 200, 255) ' وردي فاتح colors(6) = RGB(200, 255, 255) ' سماوي فاتح colors(7) = RGB(255, 220, 180) ' برتقالي فاتح colors(8) = RGB(220, 180, 255) ' بنفسجي فاتح colors(9) = RGB(180, 255, 220) ' نعناعي فاتح colors(10) = RGB(240, 240, 180) ' ليموني فاتح colorIndex = 1 ' مسح التنسيق السابق ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)).Interior.colorIndex = xlNone ' تظليل التكرارات في الصفوف For r = 3 To lr2 Set rngRow = ws.Range(ws.Cells(r, 4), ws.Cells(r, lc1)) colorDict.RemoveAll ' إعادة تعيين القاموس لكل صف For Each cell In rngRow If Not IsEmpty(cell) Then uniqueValue = cell.value ' إذا وجد تكرار في نفس الصف If Application.CountIf(rngRow, uniqueValue) > 1 Then ' إذا لم يكن هذا القيمة موجودة في القاموس، أضف لون جديد If Not colorDict.Exists(uniqueValue) Then colorDict.Add uniqueValue, colors(colorIndex) colorIndex = (colorIndex Mod 10) + 1 End If ' تطبيق اللون cell.Interior.Color = colorDict(uniqueValue) End If End If Next cell Next r ' تظليل التكرارات في الأعمدة colorDict.RemoveAll colorIndex = 1 For c = 4 To lc1 Set rngCol = ws.Range(ws.Cells(3, c), ws.Cells(lr2, c)) For Each cell In rngCol If Not IsEmpty(cell) Then uniqueValue = cell.value ' إذا وجد تكرار في نفس العمود If Application.CountIf(rngCol, uniqueValue) > 1 Then ' إذا كانت الخلية ملونة بالفعل (من تكرار الصف) If cell.Interior.Color <> xlNone Then ' تغيير اللون لمزيج من اللونين cell.Interior.Color = RGB(255, 200, 255) ' لون مميز للتكرار في كلا الاتجاهين Else ' إذا لم يكن هذا القيمة موجودة في القاموس، أضف لون جديد If Not colorDict.Exists(uniqueValue) Then colorDict.Add uniqueValue, colors(colorIndex) colorIndex = (colorIndex Mod 10) + 1 End If ' تطبيق اللون cell.Interior.Color = colorDict(uniqueValue) End If End If End If Next cell Next c ' إضافة حدود للخلايا With ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)).Borders .LineStyle = xlContinuous .Weight = xlThin .colorIndex = xlAutomatic End With End Sub

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

الكود باضافة شرط اللون :- DoCmd.OpenReport "Y_N_Report", acViewPreview, , "ddate = #" & [DDate] & "# AND NOT IsNull(colour)", , Screen.ActiveControl.Caption

الف مبروك استاذ @Ahmos الامر ليس مستغرب بل اني سبق ان اشرت وتوقعت ذلك في مداخلة مع احدهم منذ عام تحياتي

الخبير الفاضل اريد التعديل على الكود حتى لا اربط التقرير بال colour لانة يفتح تقارير اخرى لا تحتوى على colour مع العلم ان الاستعلام داخل التقرير وليس استعلام منفصل

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

الشكر ليك أخي الكريم دي شهادة أعتز بها شكراً جزيلاً بارك الله فيكم

السلام عليكم واستمرارا بتتبع والتنقيب عن الخبراء بين المشاركات ، اهدي لانفسنا الخبير @Ahmos. شكرا لك على عطاءك 🙂 جعفر

وشكرا جزيلا للخبير Ahmos 🙂

@jjafferr أخي الفاضل أسعد الله صباحك بكل الخير 1- أحتاج في عملي الي التعامل كثيراً مع بيانات متغيرة ولتسهيل مراجعتها قمت بعمل نموذج يسمح لي باضافة بعض القواعد للتحقق من البيانات وتلوينها حتي تتم المراجعة والفرز بشكل أسرع لذلك فكرت في هذا العمل حتي أتمكن من تحويل أي جدول 2- مشاركة بعض الجداول التي تحتوي علي بيانات مرجعية قد تحتاج الوصول اليها في اي وقت فيمكنك من خلال تليفونك عمل بحث وتصدير وارسال ملف الأكسل بالبيانات المطلوبة فقط كما يوجد وظيفة تمكنك من نسخ محتوي الخلية بمجرد الضغط عليها 3- عند التعامل مع بيانات متغيرة أقوم ببناء جداول كثيرة برمجياً لأنها جداول مؤقتة ولا حاجة لإعداد نماذج داخلية بالبرنامج أقوم بتعبتها وتفريغها عند الإنتهاء اما اضعها في المحفظة CLipBoard ثم انسخها داخل ملف اكسيل او اقوم بتصديرها بصيغة CSV الأن أصبح لدي خيار ثالث بمميزات أفضل هذه الأسباب الأساسية

وعليكم السلام اعمل حقل جديد في الاستعلام : myColour: len([Colour]) وفي المعيار اكتب <>0

الخبراء الافاضل بعد التحية عندى تفرير اريد فتحة بشرط ان تكون حقل colour غير فارغ برجاء التعديل على الكود الكود يعمل بكفاءة حسب التاريخ اريد اضافة اللون ايضا لكم الشكر Me.Refresh DoCmd.OpenReport "Y_N_Report", acViewPreview, , "ddate= #" & [DDate] & "#", , Screen.ActiveControl.Caption Lab.rar

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