mahmoud nasr alhasany

السلام عليكم ورحمة الله وبركاتة رجاء مساعدتى اذا سمحتم يوجد بيانات يتم تحويلها من التكست بوكس الى الليست بوكس بيانات ارقام سيارة وقيمة التفويل وبيان اللتر سولار بالارقام والحروف اريد فى حدث TEXTBOX2 يتم تحويل الارقام من العربية الى الانجليزية فى شيت 1 فى العمود 3 كمثال من لتر سولار 20.13 (للاسف لايمكن كتابة الحروف باللغة العربية ) الى لتر سولار 20.13 تحويل الارقام من العربية الى الانجليزية.xlsm

تم الحل ولاكن بكود مختلف اخر Sub UpdateStock() Dim ws As Worksheet Dim lastRow As Long, foundRow As Long Dim item As String, fromStore As String, selectedDate As Date Dim quantity As Long Dim foundMatch As Boolean Set ws = ThisWorkbook.Sheets("Sheet1") item = ComboBox4.Value fromStore = ComboBox2.Value selectedDate = CDate(TextBox15.Value) quantity = CLng(TextBox8.Value) If quantity <= 0 Then MsgBox "الكمية المحولة يجب أن تكون أكبر من الصفر", vbExclamation Exit Sub End If foundMatch = False ' Flag to indicate if a match is found With ws.Range("A2:G" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) Set foundCell = .Find(What:=item, LookIn:=xlValues, LookAt:=xlWhole, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not foundCell Is Nothing Then firstAddress = foundCell.Address Do If ws.Cells(foundCell.Row, 3).Value = fromStore And _ ws.Cells(foundCell.Row, 7).Value = selectedDate Then ws.Cells(foundCell.Row, 6).Value = ws.Cells(foundCell.Row, 6).Value + quantity foundMatch = True Exit Do End If Set foundCell = .FindNext(After:=foundCell) Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress End If ' Add new row only if no exact match was found If Not foundMatch Then lastRow = ws.UsedRange.Rows.Count + 1 With ws.Rows(lastRow) .Cells(1).Value = item .Cells(2).Value = ComboBox3.Value .Cells(3).Value = fromStore .Cells(4).Value = TextBox7.Value .Cells(5).Value = TextBox1.Value .Cells(6).Value = TextBox8.Value .Cells(7).Value = TextBox15 End With MsgBox "تم إضافة صف جديد بنجاح", vbInformation ElseIf foundMatch Then MsgBox "تم تحديث الكمية في الصف الموجود", vbInformation End If End With End Sub Private Sub CommandButton4_Click() Call UpdateStock End Sub

السلام عليكم ورحمة الله وبركاته الرجاء مساعدتى فى اضافة الكمية للمخزون على حسب كود الصنف والمخزن و تاريخ الصلاحية المطابقة لها اما اذا كانت يوجد صلاحية جديده للمنتج فيتم اضافة سطر جديد اريد تكرار الصنف والمخزن عادى مادام يوجد تاريخ صلاحية مختلفة وليست مطابقة للمخزن والصنف وتاريخ الصلاحية معا المشكلة فى فورم userform4 المشكلة فى التاريخ selectedDate = CDate(TextBox15.Value) فعندما يتوافق كود الصنف والمخزن وصلاحية المنتج معا يتم اضافة الكمية لهذ الصنف اذا كانت التاريخ متوافق ولاكن لو كان يوجد صلاحية تاريخ جديد يتم اضافة سطر جديد كود صنف ومخزن وكمية وصلاحية فوجد ان الكمية تضاف للمخزن اذا كانت الصلاحية متوافقة مثل 01/01/2024 ولاكن لو كانت صلاحية اخرى مثل اى تاريخ 02/01/2024 او 03/01/2024 والخ يتم اضافة سطر جديد مع العلم ان التاريخ لهذا الصنف والمخزن موجود والمفروض يتم اضتافة الكمية للمخزون وليس اضافة سطر جديد Private Sub CommandButton4_Click() Dim ws As Worksheet Dim lastRow As Long Dim item As String, fromStore As String Dim selectedDate As Date ' تعريف المتغير كـ Date مباشرة Dim quantity As Long Dim foundRow As Long Set ws = ThisWorkbook.Sheets("sheet1") ' تحسين: استخدام Find بدلاً من قراءة المصفوفة بالكامل With ws.columns("A") ' البحث في العمود A فقط lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row item = ComboBox4.Value fromStore = ComboBox2.Value selectedDate = CDate(TextBox15.Value) ' لا داعي لـ Format هنا، CDate يتعامل مع التواريخ بشكل جيد quantity = CLng(TextBox8.Value) If quantity <= 0 Then MsgBox "الكمية المحولة يجب أن تكون أكبر من الصفر", vbExclamation Exit Sub End If ' البحث عن التطابق Set foundCell = .Find(What:=item, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) If Not foundCell Is Nothing Then foundRow = foundCell.row ' التحقق من تطابق باقي الشروط في نفس الصف If ws.Cells(foundRow, 3).Value = fromStore And ws.Cells(foundRow, 7).Value = selectedDate Then ws.Cells(foundRow, 6).Value = ws.Cells(foundRow, 6).Value + quantity 'تحديث مباشر للكمية المخزون في الخلية على حسب نوع المخزن وكود الصنف و مطابقة التاريخ معا ' Exit Sub 'الخروج من الإجراء بعد التحديث End If End If End With ' إذا لم يتم العثور على تطابق المخزن وكود الصنف بسبب تاريخ صلاحية جديدة، يتم إضافة صف جديد lastRow = lastRow + 1 With ws.Rows(lastRow) ' استخدام With لتسهيل الكتابة .Cells(1).Value = item .Cells(2).Value = ComboBox3.Value .Cells(3).Value = fromStore .Cells(4).Value = TextBox7.Value .Cells(5).Value = TextBox1.Value .Cells(6).Value = TextBox8.Value .Cells(7).Value = selectedDate End With ' اضافة البيانات سواء كانت تحويلات او شراء الى ورقة تسجيل البيانات Dim wss As Worksheet Dim lastRow1 As Long Dim serialNumber As Long serialNumber = 1 ' تحديد ورقة العمل (قم بتغيير "Sheet1" إذا لزم الأمر) Set wss = ThisWorkbook.Sheets("تسجيل البيانات") ' العثور على آخر صف يحتوي على بيانات في العمود A lastRow1 = wss.Cells(Rows.Count, "A").End(xlUp).row serialNumber = lastRow1 '+ 1 ' كتابة القيم في الصف التالي lastRow1 = lastRow1 + 1 wss.Cells(lastRow1, "A").Value = TextBox5 wss.Cells(lastRow1, "B").Value = TextBox6 wss.Cells(lastRow1, "C").Value = ("شراء") wss.Cells(lastRow1, "D").Value = ComboBox4.Value wss.Cells(lastRow1, "E").Value = ComboBox3.Value wss.Cells(lastRow1, "F").Value = ComboBox2.Value wss.Cells(lastRow1, "g").Value = ComboBox1.Value wss.Cells(lastRow1, "h").Value = TextBox7.Value wss.Cells(lastRow1, "i").Value = TextBox1.Value wss.Cells(lastRow1, "j").Value = TextBox8.Value wss.Cells(lastRow1, "k").Value = TextBox9.Value wss.Cells(lastRow1, "l").Value = TextBox10.Value wss.Cells(lastRow1, "m").Value = TextBox11.Value wss.Cells(lastRow1, "n").Value = TextBox12.Value wss.Cells(lastRow1, "o").Value = TextBox15.Value wss.Cells(lastRow1, "p").Value = Format(Now, "DDDD MM/DD/YYYY HH:MM:SS AM/PM") 'dddd, dd mm, yyyy hh:mm:ss AM/PM End Sub stock.xlsm

الف شكر 1 / محمد هشام. احسنت والله

للاسف لقد لاحظت يوجد خطاء فى التنقل بين البيانات فى الفورم اريد تنقل البيانات مثل ترتيب هذا الاعمدة Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("تسجيل البيانات") TextBox7.Text = ws.Cells(rowNum, 2).Value ComboBox1.Text = ws.Cells(rowNum, 4).Value ComboBox2.Value = ws.Cells(rowNum, 5).Value ComboBox3.Value = ws.Cells(rowNum, 6).Value ComboBox4.Value = ws.Cells(rowNum, 7).Value TextBox3.Text = ws.Cells(rowNum, 8).Value TextBox4.Text = ws.Cells(rowNum, 9).Value TextBox5.Text = ws.Cells(rowNum, 10).Value TextBox6.Text = ws.Cells(rowNum, 11).Value ComboBox5.Value = ws.Cells(rowNum, 12).Value

احسنت 1 / محمد هشام. الف شكر لك

احسنت ا / محمد هشام.

السلام عليكم ورحمة الله وبركاته الرجاء مساعدتى فى هذا العمل اريد التنقل بين السجلات برقم الفاتورة فقط دون غيرها من ارقام الفواتير الاخرى فى textbox8 من خلال SpinButton2_SpinDown SpinButton2_SpinUp Private Sub TextBox8_Change() Dim ws As Worksheet Dim rng As Range Dim foundRows As New Collection Dim i As Long Set ws = ThisWorkbook.Sheets("تسجيل البيانات") Set rng = ws.Range("A2:L10000") ' foundRows.RemoveAll For Each cell In rng.Columns(1).Cells If cell.Value = TextBox8.Text Then foundRows.ADD cell.Row End If Next cell If foundRows.Count = 0 Then MsgBox "No matching records found." Exit Sub End If ' Display the first match i = 1 DisplayRecord (foundRows(i)) End Sub Private Sub SpinButton2_SpinDown() If i > 1 Then i = i - 1 DisplayRecord (foundRows(i)) End If End Sub Private Sub SpinButton2_SpinUp() If i < foundRows.Count Then i = i + 1 DisplayRecord (foundRows(i)) End If End Sub Private Sub DisplayRecord(rowNum As Long) Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("تسجيل البيانات") TextBox7.Text = ws.Cells(rowNum, 2).Value ComboBox1.Text = ws.Cells(rowNum, 4).Value ComboBox2.Value = ws.Cells(rowNum, 5).Value ComboBox3.Value = ws.Cells(rowNum, 6).Value ComboBox4.Value = ws.Cells(rowNum, 7).Value TextBox3.Text = ws.Cells(rowNum, 8).Value TextBox4.Text = ws.Cells(rowNum, 9).Value TextBox5.Text = ws.Cells(rowNum, 10).Value TextBox6.Text = ws.Cells(rowNum, 11).Value ComboBox5.Value = ws.Cells(rowNum, 12).Value End Sub textbox8 بحث والتنقل بين السجلات برقم الفاتورة.xlsm

تم عمل المطلوب قنم بوضع الاسم فى الفورم 2 textbox3 ثم قم باختيار من لوحة المفاتيح الامر F4 للانتقال بوضع الاسم الذى تم اختيارة فى listbox1 من خلال انتقال الاسهم من لوحة المفاتيح بعد الامر مباشرة F4 وعند اختيار الاسم المحدد قم باختيار الامر F2 للانتقال الى الفورم 1 وشكرا شاشة عميل بحث(1).xlsm

الف شكر استاذ / أبومروان انه يعمل اريد ان تساعدنى فى ان افعل الاسهم بتاعت الكيبورت للانتقال اعلى واسفل من خلال الليست بوكس بعد تحديد اول بيانات الاسم فى الليست بوكس شاشة عميل بحث(1).xlsm

السلام عليكم ورحمة الله وبركاتة تحية طيبة وبعد اريد مساعدتى فى تشغيل تشغيل مفتاح F4 في حدث فورم VBA Excel والانتقال الى القائمة فى LISTBOX1 وايضا تشغيل مفتاح F2 في حدث فورم VBA Excel والانتقال الى Userform1 الى حدث combobox1 من خلال تحديد الاسم الموجود فى LISTBOX1 فى Userform2 كمثال فى Userform2 يوجد textbox3 اضع اول حرف او اسم فى textbox3 وعند الضغط على مفتاح F4 ينتقل الى اول الاسماء فى LISTBOX1 وعند تحديد اسم فى LISTBOX1 وعند الضغط على مفتاح F2 ينتقل بعد تحديد الاسم فى LISTBOX1 الى Userform1 الى حدث combobox1 وشكرا شاشة عميل بحث.xlsm

الف شكر استاذنا / محمد هشام على المجهود الرائع تسلم ايدك احسنت والله

الف شكر استاذنا / محمد هشام على المجهود الرائع واضافة ترتيب البيانات على حسب الرغبة الف شكر لك هل يمكن عمل التقويم تاريخ بدل اظهارها رقميا كما يوجد فى الفورم من textbox9,10 بدل 2,3 combobox

هذا الملف بعد تعديله نأسف على الخطاء وهذا الكود لايقوم بعرض 12 عمود ولاكنه يعرض 10 فقط Private Sub CommandButton7_Click() Dim ws As Worksheet Dim lastRow As Long Dim searchValue1 As String Dim searchValue2 As String Dim currentRow As Long Dim DateMin As Date Dim DateMax As Date Dim includeDates As Boolean ' تحديد ورقة العمل Set ws = Worksheets("Sheet2") ' الحصول على القيم من عناصر التحكم searchValue1 = ComboBox4.value searchValue2 = ComboBox5.value If IsDate(TextBox9.value) Then DateMin = CDate(TextBox9.value) If IsDate(TextBox10.value) Then DateMax = CDate(TextBox10.value) includeDates = CheckBox1.value ' تحديد قيمة مربع الاختيار Dim userEndDate As Date ' التحقق من صحة التاريخ المدخل في TextBox2 If IsDate(TextBox10.value) Then userEndDate = CDate(TextBox10.value) If userEndDate > Date Then MsgBox "تاريخ النهاية لا يمكن أن يكون أكبر من تاريخ اليوم." Exit Sub End If End If ' تحديد الصف الأخير lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' مسح قائمة النتائج وتحديد عرض الأعمدة With ListBox1 .Clear .ColumnCount = 12 .ColumnWidths = "35;50;45;50;65;40;35;40;45;40;45;40" .Font.Size = 6 End With currentRow = 0 For i = 2 To lastRow If (LCase(ws.Cells(i, 3).value) = LCase(searchValue1) Or searchValue1 = "ALL") And _ (LCase(ws.Cells(i, 4).value) = LCase(searchValue2) Or searchValue2 = "ALL") And _ ws.Cells(i, 3).value Like "*" & searchValue1 & "*" And _ (Not includeDates Or (ws.Cells(i, 2) >= DateMin And ws.Cells(i, 2) <= DateMax)) Then ' إضافة البيانات إلى القائمة ListBox1.AddItem ListBox1.List(currentRow, 0) = ws.Cells(i, 1).value ListBox1.List(currentRow, 1) = Format(ws.Cells(i, 2).value, "dd/mm/yyyy") ListBox1.List(currentRow, 2) = ws.Cells(i, 3).value ' ListBox1.List(currentRow, 3) = ws.Cells(i, 4).value ' ListBox1.List(currentRow, 4) = ws.Cells(i, 5).value ' ListBox1.List(currentRow, 5) = ws.Cells(i, 6).value ' ListBox1.List(currentRow, 6) = ws.Cells(i, 7).value ListBox1.List(currentRow, 7) = ws.Cells(i, 8).value ' ListBox1.List(currentRow, 8) = ws.Cells(i, 9).value ' ListBox1.List(currentRow, 9) = ws.Cells(i, 10).value ' ListBox1.List(currentRow, 10) = ws.Cells(i, 11).value ' ListBox1.List(currentRow, 11) = ws.Cells(i, 12).value currentRow = currentRow + 1 End If Next i If ListBox1.ListCount = 0 Then MsgBox "لم يتم العثور على نتائج" End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' كود اخر بحث Private Sub CommandButton6_Click() On Error Resume Next Dim ws As Worksheet Dim lastRow As Long Dim i As Long, j As Long Dim startDate As Date, endDate As Date ' تحديد ورقة العمل Set ws = ThisWorkbook.Sheets("Sheet2") ' تحديد النطاق الكامل للبيانات lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row ' تحويل التواريخ من نص إلى تنسيق التاريخ startDate = CDate(TextBox9.value) endDate = CDate(TextBox10.value) ' مسح البيانات السابقة من ListBox ListBox1.Clear ' تحديد عدد الأعمدة في ListBox ListBox1.ColumnCount = 12 ' ملء ListBox بالبيانات التي تطابق المعايير For i = 2 To lastRow If ws.Cells(i, "b").value >= startDate And ws.Cells(i, "b").value <= endDate And ws.Cells(i, "c").value = ComboBox4.value And _ ws.Cells(i, "d").value = ComboBox5.value Then ' قم بتغيير أرقام الأعمدة إذا لزم الأمر ListBox1.AddItem For j = 1 To 12 If Not IsEmpty(ws.Cells(i, j)) Then ListBox1.List(ListBox1.ListCount - 1, j - 1) = CStr(ws.Cells(i, j).value) ' تحويل القيمة إلى نص إذا لزم الأمر End If Next j End If Next i End Sub ListBox1.ColumnCount = 12.xlsm

اهلا وسهلا استاذنا / محمد هشام تقصد For i = 2 To lastRow If Trim(ws.Cells(i, "d").value) = ComboBox5.value Then ComboBox4.value = ws.Cells(i, "c").value Exit For End If Next i شكرا على الملاحظة ولاكن توجد مشكلة عرض الاعمدة وفقا لتاريخ والشروط لايتم لانها تعرض 10 اعمدة بدل من 12 لو وضعنا خاصية On Error Resume Next

السلام عليكم ورحمة الله وبركاتة رجاء مساعدتى جزاك الله خيرا يوجد خيارين بحث وكلاهما لايعمل بسبب انه لايتم عرض 12 عمود فى الليست بوكس ولاكن يتم عرض 10 اعمده فقط ListBox1.ColumnCount = 12.xlsm

Dim totalValue As Double Dim targetValue1 As Double Dim targetValue2 As Double ' Get values from TextBoxes totalValue = Val(TextBox10.Value) targetValue1 = Val(TextBox11.Value) targetValue2 = Val(TextBox12.Value) ' Check for feasibility If targetValue1 + targetValue2 <> totalValue Then MsgBox "Target values do not match total value.", vbCritical Exit Sub End If ' Initialize banknote counts Dim count200 As Integer: count200 = Val(TextBox1.Value) Dim count100 As Integer: count100 = Val(TextBox2.Value) Dim count50 As Integer: count50 = Val(TextBox3.Value) ' Create arrays to store distribution Dim group1(1 To 3) As Integer Dim group2(1 To 3) As Integer ' Random distribution loop Do ' Reset group values For i = 1 To 3 group1(i) = 0 group2(i) = 0 Next i ' Randomly assign 200 denomination banknotes Randomize For i = 1 To count200 If Rnd() < 0.5 Then group1(1) = group1(1) + 1 Else group2(1) = group2(1) + 1 End If Next ' Randomly assign 100 denomination banknotes Randomize For i = 1 To count100 If Rnd() < 0.5 Then group1(2) = group1(2) + 1 Else group2(2) = group2(2) + 1 End If Next ' Randomly assign 50 denomination banknotes Randomize For i = 1 To count50 If Rnd() < 0.5 Then group1(3) = group1(3) + 1 Else group2(3) = group2(3) + 1 End If Next ' Calculate the total value of each group Dim group1Total As Double: group1Total = group1(1) * 200 + group1(2) * 100 + group1(3) * 50 Dim group2Total As Double: group2Total = group2(1) * 200 + group2(2) * 100 + group2(3) * 50 Loop Until group1Total = targetValue1 And group2Total = targetValue2 ' Display the distribution in TextBoxes or other controls TextBox4.Value = group1(1) TextBox7.Value = group2(1) TextBox5.Value = group1(2) TextBox8.Value = group2(2) TextBox6.Value = group1(3) TextBox9.Value = group2(3) لقد وجدت الحل بحمدلله

مالمشكلة رجاء مساعدتى توزيع فئات2 .xlsm

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى يوجد خطاء فى توزيعة الخاصة بالفئات 100 اما الباقى مظبوط اولا الرجاء ادخال الارقام اولا ثم ادخال القيمة 1 او القيمة 2 ستجد القيمة 2 يوجد بها خطاء فى توزيع الارقام فى خانة 100 15 =8+8 بدل 15 =8+7 توزيع فئات2 .xlsm

احسنت أ / حسونة حسين احسنت أ / محمد هشام على المجهود الرائع الذى بزلتموه

احسنت ا / محمد هشام عمل رائع

السلام عليكم ورحمة اللة وبركاتة الرجاء مساعدتى فى عملية بحث جزء من حروف معينة عند كتابتها فى textbox3 فعندما يتم عرضها فى listbox1 يقوم بظهور جزء من الحروف ملونة فى listbox1 وليس الكلمات كلها ان الكود يعمل جيدا ولاكن اريد اضافة خيار لون الحروف التى يتم استعلام عنها فى textbox3 تظهر فى عرض بيانات يظهر جزء من الحروف ملونة فى listbox1 فهل يوجد كود بالروعة دى يعمل هنا شاشة عميل بحث1.xlsm

وجدت الحل بحمدلله Private Sub CheckBox1_Click() Dim arr() As Variant Dim i As Long, j As Long, temp As Variant Dim sortColumn As Integer Dim sortOrder As Boolean ' نسخ البيانات من ListBox إلى المصفوفة ReDim arr(ListBox1.ListCount - 1, ListBox1.ColumnCount - 1) For i = 0 To ListBox1.ListCount - 1 For j = 0 To ListBox1.ColumnCount - 1 arr(i, j) = ListBox1.List(i, j) Next j Next i ' تحديد عمود الفرز بناءً على ComboBox sortColumn = ComboBox1.ListIndex ' تحديد اتجاه الفرز بناءً على CheckBox sortOrder = CheckBox1.Value ' الفرز باستخدام Bubble Sort For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If sortOrder Then ' ترتيب تنازلي If IsNumeric(arr(i, sortColumn)) Or IsNumeric(arr(j, sortColumn)) Then If CDbl(arr(i, sortColumn)) > CDbl(arr(j, sortColumn)) Then ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Else If UCase(arr(i, sortColumn)) > UCase(arr(j, sortColumn)) Then ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If End If Else ' ترتيب تصاعدي If IsNumeric(arr(i, sortColumn)) Or IsNumeric(arr(j, sortColumn)) Then If CDbl(arr(i, sortColumn)) < CDbl(arr(j, sortColumn)) Then ' تبادل السجلين ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Else If UCase(arr(i, sortColumn)) < UCase(arr(j, sortColumn)) Then ' تبادل السجلين ' تبادل السجلين For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If End If End If

السلام عليكم ورحمة الله وبركاتة رجاء مساعدتى فى comobobx1 يوجد خيارين "كود "و "اسم العميل" كود مرتبط بالعمود الاول واسم العميل مرتبط بالعمود الثانى فى listbox1 ملحوظة عندما اختار كلمة كود فى combobox يقوم بالترتيب تنازلى او تصاعدى من خلال Checkbox انه يعمل جيدا ولاكن عند اقوم باختار كلمة اسم عميل فى combobox لا يقوم بالترتيب تنازلى او تصاعدى من بواسطة Checkbox عندما اضغط على امر Private Sub CommandButton8_Click() Private Sub CommandButton8_Click() Dim arr() As Variant Dim i As Long, j As Long, temp As Variant Dim sortColumn As Integer Dim sortOrder As Boolean ' التأكد من وجود بيانات في ListBox If ListBox1.ListCount = 0 Then MsgBox "لا توجد بيانات لفرزها", vbExclamation Exit Sub End If ' تحديد عمود الفرز بناءً على ComboBox sortColumn = ComboBox1.ListIndex + 1 ' نفترض أن الفهرس يبدأ من 0 ' تحديد اتجاه الفرز بناءً على CheckBox sortOrder = CheckBox1.Value ' نسخ البيانات من ListBox إلى المصفوفة ReDim arr(ListBox1.ListCount - 1, ListBox1.ColumnCount - 1) For i = 0 To ListBox1.ListCount - 1 For j = 0 To ListBox1.ColumnCount - 1 arr(i, j) = ListBox1.List(i, j) Next j Next i ' الفرز باستخدام Bubble Sort For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If sortOrder And arr(i, sortColumn) > arr(j, sortColumn) Then ' ترتيب تنازلي ' تبادل السجلين بالكامل For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k ElseIf Not sortOrder And arr(i, sortColumn) < arr(j, sortColumn) Then ' ترتيب تصاعدي ' تبادل السجلين بالكامل For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Next j Next i ' مسح البيانات القديمة وإضافة البيانات الجديدة ListBox1.Clear For i = LBound(arr) To UBound(arr) ListBox1.AddItem For j = LBound(arr, 2) To UBound(arr, 2) ' ListBox1.List(i, j - 1) = arr(i, j) ' نبدأ من الصفر في ListBox ListBox1.List(i, j) = arr(i, j) Next j Next i With ListBox1 .Font.Size = 12 ' تغيير حجم الخط إلى 12 .ColumnCount = 2 .ColumnWidths = "80;120" ' .Font.Color = vbBlue ' تغيير لون الخط إلى الأزرق .BackColor = RGB(255, 255, 204) ' تغيير لون الخلفية إلى أصفر فاتح End With End Sub شاشة عميل بحث.xlsm

لو افترضنا ان يوجد فى textbox1 قيمة 15 نريد تحويلها على textbox4 ,textbox7 ليكون الناتج فى textbox4 7 ليكون الناتج فى textbox4 8 ولا لايعمل فما الحل Private Sub CommandButton26_Click() Dim total200 As Integer, total100 As Integer, total50 As Integer, totalValue As Integer Dim percent200 As Double, percent100 As Double, percent50 As Double, halfPercent As Double Dim group1Total As Integer, group2Total As Integer Dim CalculateTotal As Integer ' التحقق من صحة المدخلات If Not IsNumeric(TextBox11.Text) Or Not IsNumeric(TextBox12.Text) Then ' MessageBox.Show ("الرجاء إدخال قيم عددية في حقل الإجمالي") Exit Sub End If ' التحقق من صحة البيانات If total200 < 0 Or total100 < 0 Or total50 < 0 Then MessageBox.Show ("الرجاء إدخال قيم موجبة") Exit Sub End If If group1Total + group2Total < totalValue Then MessageBox.Show ("مجموع القيم المستهدفة أقل من مجموع القيم المتاحة") Exit Sub End If ' جمع قيم الفئات total200 = Val(TextBox1.Text) + Val(TextBox4.Text) + Val(TextBox7.Text) total100 = Val(TextBox2.Text) + Val(TextBox5.Text) + Val(TextBox8.Text) total50 = Val(TextBox3.Text) + Val(TextBox6.Text) + Val(TextBox9.Text) totalValue = total200 * 200 + total100 * 100 + total50 * 50 ' حساب النسبة المئوية لكل فئة percent200 = total200 * 200 / totalValue percent100 = total100 * 100 / totalValue percent50 = total50 * 50 / totalValue ' توزيع النسب المئوية على المجموعتين group1Total = Val(TextBox11.Text) group2Total = Val(TextBox12.Text) ' توزيع فئة 200 TextBox4.Text = Math.Round((percent200 * 1 - halfPercent) * group1Total / 200) TextBox7.Text = Math.Round((percent200 * (1 - halfPercent)) * group2Total / 200) ' توزيع فئة 100 TextBox5.Text = Math.Round((percent100 * 1 - halfPercent) * group1Total / 100) TextBox8.Text = Math.Round((percent100 * (1 - halfPercent)) * group2Total / 100) ' توزيع فئة 50 TextBox6.Text = Math.Round((percent50 * 1 - halfPercent) * group1Total / 50) TextBox9.Text = Math.Round((percent50 * (1 - halfPercent)) * group2Total / 50) halfPercent = 0.5 ' حساب القيم العددية الإجمالية Me.TextBox58 = Val(TextBox1) + Val(TextBox2) + Val(TextBox3) Me.TextBox59 = Val(TextBox4) + Val(TextBox5) + Val(TextBox6) Me.TextBox60 = Val(TextBox7) + Val(TextBox8) + Val(TextBox9) ' حساب القيم النقدية الإجمالية باستخدام الدالة Me.TextBox13.Value = Val(Me.TextBox1.Value) * 200 Me.TextBox14.Value = Val(Me.TextBox2.Value) * 100 Me.TextBox15.Value = Val(Me.TextBox3.Value) * 50 Me.TextBox16.Value = Val(Me.TextBox4.Value) * 200 Me.TextBox17.Value = Val(Me.TextBox5.Value) * 100 Me.TextBox18.Value = Val(Me.TextBox6.Value) * 50 Me.TextBox19.Value = Val(Me.TextBox7.Value) * 200 Me.TextBox20.Value = Val(Me.TextBox8.Value) * 100 Me.TextBox21.Value = Val(Me.TextBox9.Value) * 50 End Sub للاسف يوجد مشكلة فى الكودين هذا ' توزيع فئة 200 TextBox4.Text = Math.Round((percent200 * 1 - halfPercent) * group1Total / 200) TextBox7.Text = Math.Round((percent200 * (1 - halfPercent)) * group2Total / 200) ' توزيع فئة 100 TextBox5.Text = Math.Round((percent100 * 1 - halfPercent) * group1Total / 100) TextBox8.Text = Math.Round((percent100 * (1 - halfPercent)) * group2Total / 100) ' توزيع فئة 50 TextBox6.Text = Math.Round((percent50 * 1 - halfPercent) * group1Total / 50) TextBox9.Text = Math.Round((percent50 * (1 - halfPercent)) * group2Total / 50) halfPercent = 0.5 ولقد استعملت اكثر من دالة ولا يعمل معى مثل TextBox4.Text = Int((percent200 * 1 - halfPercent) * group1Total / 200) TextBox4.Text = Math.Round((percent200 * 1 - halfPercent) * group1Total / 200) TextBox4.Text = Fix((percent200 * 1 - halfPercent) * group1Total / 200) ولا اعرف ماذا افعل انظر الصورة وطبق المسألة المطروحة فى الصورتين لتجد الاختلاف مسألة.xlsm