نجوم المشاركات

Sub ConnectToSQL() Dim conn As ADODB.Connection Dim rs As ADODB.Recordset ' تكوين اتصال ODBC Set conn = New ADODB.Connection conn.Open "DSN=MySQLServer;UID=myusername;PWD=mypassword" ' تنفيذ استعلام SQL Set rs = New ADODB.Recordset rs.Open "SELECT * FROM Customers", conn ' عرض النتائج في نموذج (على سبيل المثال) Do While Not rs.EOF Me.txtCustomerID.Value = rs!CustomerID Me.txtCustomerName.Value = rs!CustomerName rs.MoveNext Loop ' إغلاق الاتصال والسجل rs.Close Set rs = Nothing conn.Close Set conn = Nothing End Sub

ضغط والله علي أفضل إجابة بس النت عندي بطئ

تفضل استاذ @سامر محمود حسب مافهمت . ووافني بالرد . Search By First Name.rar

شكرا أخي الفاضل وبارك الله فيك وأكثر الله من أمثالك

تفضل استاذ @2saad المرفق والشرح بعد التعديل . ووافني بالرد . البحث وتعديل درجات9-2.rar

تمام بارك الله فيك استاذنا عبدالله بشير

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

جميل جدا ماشاء الله جزاكم الله خيرا🌹

بارك الله فيك اخي kkhalifa1960 جزاك الله كل خير

وعليكم السلام ورحمة الله وبركاته الكود Sub DistributeStudents() Dim ws As Worksheet Dim lastRow As Long Dim dataRange As Variant Dim outputRange As Variant Dim rowNum As Long, colNum As Long Dim colStart As Integer, colEnd As Integer Dim totalStudents As Long, committees As Long Dim studentsPerCommittee As Long, extraStudents As Long Dim failedRows As String Const MaxStudentsPerCommittee As Long = 29 Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, 9).End(xlUp).row colStart = 11 colEnd = 30 ' Clear the output range ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).ClearContents ws.Range("I2:I" & lastRow).Interior.Color = xlNone ' إزالة أي ألوان سابقة dataRange = ws.Range("I2:J" & lastRow).Value ReDim outputRange(1 To UBound(dataRange, 1), colStart To colEnd) failedRows = "" For rowNum = 1 To UBound(dataRange, 1) totalStudents = dataRange(rowNum, 1) committees = dataRange(rowNum, 2) If committees > (colEnd - colStart + 1) Then MsgBox "عدد اللجان في الصف " & rowNum + 1 & " يتجاوز الحد الأقصى للأعمدة المتاحة!", vbExclamation Exit Sub End If If totalStudents = 0 Or committees = 0 Then For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum Else If totalStudents > committees * MaxStudentsPerCommittee Then ws.Cells(rowNum + 1, 9).Interior.Color = RGB(255, 0, 0) For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum failedRows = failedRows & (rowNum + 1) & ", " Else studentsPerCommittee = totalStudents \ committees extraStudents = totalStudents Mod committees For colNum = colStart To colStart + committees - 1 If extraStudents > 0 Then outputRange(rowNum, colNum) = studentsPerCommittee + 1 extraStudents = extraStudents - 1 Else outputRange(rowNum, colNum) = studentsPerCommittee End If Next colNum For colNum = colStart + committees To colEnd outputRange(rowNum, colNum) = "" Next colNum End If End If Next rowNum ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).Value = outputRange If failedRows <> "" Then failedRows = Left(failedRows, Len(failedRows) - 2) ' إزالة الفاصلة الأخيرة MsgBox "تم توزيع الطلاب على اللجان بنجاح! ولكن لم يتم توزيع الطلاب في الصفوف التالية بسبب تجاوز الحد الأقصى لعدد الطلبة على عدداللجان: " & vbCrLf & failedRows, vbExclamation Else MsgBox "تم توزيع الطلاب على اللجان بنجاح!", vbInformation End If End Sub الملف التوزيع.xlsb

تفضل أخي . واذا كان هذا اضغط على أفضل اجابة . DD12-2024-1-1.rar

سلام عليكم اليك مايضاف الى الماكرو لتسريع تنفيذه تجده في المرفق للامانة هذا من اعمال المنتدى جزاهم الله خيرا لي سؤال الى الاستاذ ابو مروان اين يضع ذاك الماكرو لتسريع تنفيذ الماكرو.xlsx

Private Sub TextBox4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If (KeyAscii >= 48 And KeyAscii <= 57) Or KeyAscii = 46 Then Else KeyAscii = 0 MsgBox "يجب ادخال ارقام فقط", vbCritical End If End Sub جرب الكود التالى ربما هو المطلوب