mahmoud nasr alhasany

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

الف شكر استاذنا / محمد هشام على المجهود الرائع واضافة ترتيب البيانات على حسب الرغبة الف شكر لك هل يمكن عمل التقويم تاريخ بدل اظهارها رقميا كما يوجد فى الفورم من 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

لقد وجدت حل ولاكن القيم العددية للاسف غير مظبوطة 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) halfPercent = 0.5 ' توزيع فئة 200 TextBox4.Text = CInt((percent200 * halfPercent) * group1Total / 200) TextBox7.Text = CInt((percent200 * (1 - halfPercent)) * group2Total / 200) ' توزيع فئة 100 TextBox5.Text = CInt((percent100 * halfPercent) * group1Total / 100) TextBox8.Text = CInt((percent100 * (1 - halfPercent)) * group2Total / 100) ' توزيع فئة 50 TextBox6.Text = CInt((percent50 * halfPercent) * group1Total / 50) TextBox9.Text = CInt((percent50 * (1 - halfPercent)) * group2Total / 50) ' حساب القيم العددية الإجمالية 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 انظر الصورة الاولى غير مظبوطة اما الصورة الثانية اريدها هكذا

شكرا جزيلا لك ا/ محمد هشام انا لا اقصد اوزان فأنها خطاء كتابى نظرا لانى كنت اكتب بالهاتف انا اقصد ان الاعداد الفردية التى ادرجتها فى textbox1,2,3 تعادل قيمة النقدية فى textbox10 =2000 * TextBox1: 10 *200 =1500 * TextBox2: 15 * 100 =400 * TextBox3: 8 * 50 لو وضعنا القيمة النقدية فى textbox11 ,ولنفترض 2000 والقيمة النقدية فى textbox12 ,ولنفترض 1900 اريد الارقام العددية فى textbox1,2,3 توزع عشوائى الى textbox4,5,6 وفقا للقيمة فى textbo11 وايضا توزع الى textbox7,8,9 وفقا للقيمة فى textbox12 وهذا هو المطلوب كما سأوضحة فى الصورتان قبل وبعد

الفكرة مثلا هى عند وضع القيم العددية فى * TextBox1: 10 *200 * TextBox2: 15 * 100 * TextBox3: 8 * 50 تكون مجموع الناتج فى textbox10 3900 اريد وضع القيم النقدية textbox11 1900 ليقوم بتوزيع قيم عدديه على حسب الارقام المقابل لها فى textbox1,2,3 وتوزيعها الى * TextBox4: 5 * TextBox5: 7 * TextBox6: 4 وكذلك على حسب القيم النقدية textbox12 2000 على حسب الارقام المقابل لها فى textbox1,2,3 وتوزيعها الى * TextBox7: 5 * TextBox 8: 8 * TextBox9: 4 * قراءة القيم: نقوم بقراءة القيم العددية من النصوص TextBox1, TextBox2, TextBox3 والقيم النقدية من TextBox11 و TextBox12. * حساب الأوزان النسبية: نحسب الوزن النسبي لكل قيمة عددية بناءً على قيمتها الإجمالية. * حساب المبالغ الموزعة: نحسب المبلغ الذي سيتم توزيعه لكل نص بناءً على الوزن النسبي والقيمة النقدية. * توزيع القيم: نقوم بتعيين القيم المحسوبة في النصوص المستهدفة (TextBox4 إلى TextBox9).

الفكرة مثلا هى عند وضع القيم العددية فى * TextBox1: 10 *200 * TextBox2: 15 * 100 * TextBox3: 8 * 50 تكون مجموع الناتج فى textbox10 3900 اريد وضع القيم النقدية textbox11 1900 ليقوم بتوزيع قيم عدديه على حسب الارقام المقابل لها فى textbox1,2,3 وتوزيعها الى TextBox4: 5 TextBox5: 7 TextBox6: 4 وكذلك على حسب القيم النقدية textbox12 2000 ليقوم بتوزيع قيم عدديه على حسب الارقام المقابل لها فى textbox1,2,3 وتوزيعها الى TextBox7: 5 TextBox8: 8 TextBox9: 4 ويكون خصم القيم العدديه متساويه مع القيم العددية فى نقديه ١ ونقديه ٢

احسنت ا/محمد هشام هل يمكن تعديل الكود رجاء بحيث لو أن القيمة الإجمالية مثلا فى textbox10 هى 3900 بحيث اتحكم فى وضع القيمة النقديه ١ مثلا 1000 والقيمة النقدية ٢ 2900 وتوزيع القيمة فئات الاعداد على حسب القيمة المدرجة الذى وضعتها وشكرا

الف شكر ا/ محمد هشام على الاهتمام احب أنوه على ملحوظة فى نقدية ١ اولا فى فئة 100 *7=700 وليست 800 ثانيا بالنسبة للمبلغ المفترض فى textbox10 يكون الإجمالي 3900 لانه هو المبلغ الأساسى الذى يتم توزيع المبالغ العددية عشوائى وبالتساوى إلى نقديه ا ونقديه ٢ أما بالنسبة للمبلغ المفترض فى textbox11 يكون الإجمالي 1900 أما بالنسبة للمبلغ المفترض فى textbox12 يكون الإجمالي 2000 وهذا هو المطلوب

السلام عليكم ورحمة الله وبركاتة لقد صممت فورم به اجمالى المبلغ مع قيم العددية فئات يتم توزيعها على مجموعتين نقدية 1 ونقدية 2 ويوجد المجموع الكلى قبل التوزيع فى Textbox10 ويوجد المجموع نقدية 1 فى Textbox11 ويوجد المجموع نقدية 2 فى Textbox12 ولاكن القيم النقدية فى textbox10,11,12 غير مظبوطة مع المجموعات كما هى مدرجة فى الصورة المرفقة مع العلم انى كنت اريد توزيع القيم العددية الى نقدية 1 و2 على حسب مجموع القيم النقدية وليس العددية فى textbox11,12 Private Sub CommandButton24_Click() Dim قيمة1 As Long, قيمة2 As Long, قيمة3 As Long Dim نصف_القيمة1 As Double, نصف_القيمة2 As Double, نصف_القيمة3 As Double Dim إجمالي_نقدية1 As Double, إجمالي_نقدية2 As Double, إجمالي_كلية As Double Dim نسبة_نقدية1 As Double, نسبة_نقدية2 As Double ' التحقق من صحة الإدخال (يمكن إضافة المزيد من التحقيقات حسب الحاجة) If Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Or Not IsNumeric(TextBox3.Value) Then MsgBox "الرجاء إدخال أعداد صحيحة موجبة فقط." Exit Sub End If If Val(TextBox1.Value) <= 0 Or Val(TextBox2.Value) <= 0 Or Val(TextBox3.Value) <= 0 Then MsgBox "الرجاء إدخال أعداد أكبر من الصفر." Exit Sub End If ' قراءة القيم من النصوص قيمة1 = Val(TextBox1.Value) قيمة2 = Val(TextBox2.Value) قيمة3 = Val(TextBox3.Value) ' حساب النصف لكل قيمة نصف_القيمة1 = قيمة1 / 2 نصف_القيمة2 = قيمة2 / 2 نصف_القيمة3 = قيمة3 / 2 ' تحويل الأجزاء العشرية إلى أعداد صحيحة وتوزيع الباقي TextBox4.Value = Int(نصف_القيمة1) TextBox5.Value = Int(نصف_القيمة2) TextBox6.Value = Int(نصف_القيمة3) TextBox7.Value = قيمة1 - TextBox4.Value TextBox8.Value = قيمة2 - TextBox5.Value TextBox9.Value = قيمة3 - TextBox6.Value 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 ' حساب القيم الإجمالية (مع التعديل) إجمالي_نقدية1 = TextBox13.Value * Val(TextBox4.Value) + TextBox14.Value * Val(TextBox5.Value) + TextBox15.Value * Val(TextBox6.Value) إجمالي_نقدية2 = TextBox13.Value * Val(TextBox7.Value) + TextBox14.Value * Val(TextBox8.Value) + TextBox15.Value * Val(TextBox9.Value) إجمالي_كلية = إجمالي_نقدية1 + إجمالي_نقدية2 If إجمالي_كلية <> 0 Then نسبة_نقدية1 = إجمالي_نقدية1 / إجمالي_كلية نسبة_نقدية2 = إجمالي_نقدية2 / إجمالي_كلية Else MsgBox "حدث خطأ: الإجمالي الكلي يساوي صفرًا." Exit Sub End If ' بدلاً من توزيع القيم بناءً على النسبة المئوية، يمكن توزيعها بالتساوي TextBox11.Value = (نصف_القيمة1 + نصف_القيمة2 + نصف_القيمة3) / 2 TextBox12.Value = (نصف_القيمة1 + نصف_القيمة2 + نصف_القيمة3) / 2 TextBox11.Value = Format(إجمالي_نقدية1, "$#,##0.00") TextBox12.Value = Format(إجمالي_نقدية2, "$#,##0.00") TextBox10.Value = Format(إجمالي_كلية, "$#,##0.00") Me.TextBox59 = Val(TextBox4) + Val(TextBox5) + Val(TextBox6) Me.TextBox60 = Val(TextBox7) + Val(TextBox8) + Val(TextBox9) MsgBox "تم التوزيع بنجاح." End Sub توزيع فئات نقدية.xlsm

الف شكر / محمد هشام على التوضيح بعض النقاط توضيحا جيدا وجزاك الله عنا خير الجزاء وهذا الكود بعد اضافة خيار التاريخ اذا لزم الامر Private Sub CommandButton1_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("Sheet3") ' الحصول على القيم من عناصر التحكم searchValue1 = ComboBox1.Value searchValue2 = ComboBox3.Value If IsDate(TextBox1.Value) Then DateMin = CDate(TextBox1.Value) If IsDate(TextBox2.Value) Then DateMax = CDate(TextBox2.Value) includeDates = CheckBox1.Value ' تحديد قيمة مربع الاختيار ' تحديد الصف الأخير lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' مسح قائمة النتائج وتحديد عرض الأعمدة With ListBox2 .Clear .ColumnCount = 6 .ColumnWidths = "35;60;45;40;65;40" .Font.Size = 10 End With ' البحث عن البيانات وتعبئة القائمة currentRow = 0 For i = 2 To lastRow ' التحقق من الشروط If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" And _ (Not includeDates Or (ws.Cells(i, 6) >= DateMin And ws.Cells(i, 6) <= DateMax)) Then ' إضافة البيانات إلى القائمة ListBox2.AddItem ListBox2.List(currentRow, 0) = ws.Cells(i, 1).Value ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ' سعر ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ' كمية المخزون ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ' اسم المخزن 'ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value ' تاريخ نهاية الصنف ListBox2.List(currentRow, 5) = Format(ws.Cells(i, 6).Value, "dd/mm/yyyy") ' تاريخ نهاية الصنف currentRow = currentRow + 1 End If Next i If ListBox2.ListCount = 0 Then MsgBox "لم يتم العثور على نتائج" End If TextBox7.Text = "عدد السجلات في القائمة : (" & ListBox2.ListCount & ")" Call TOtal End Sub

شكرا لك محمد هشام. الكود يعمل جيدا ولاكن اريد اظهار البيانات داخل رؤوس الاعمدة ListBox2.ColumnHeads = True Private Sub CommandButton1_Click() Dim ws As Worksheet Dim lastRow As Long Dim searchValue1 As String Dim searchValue2 As String Dim currentRow As Long Dim colHeaders As Variant searchValue1 = ComboBox1.Value searchValue2 = ComboBox3.Value Set ws = Worksheets("Sheet3") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' تعريف رؤوس الأعمدة colHeaders = Array("كود", "صنف", "سعر", "كمية المخزون", "اسم المخزن", "تاريخ نهاية الصنف") colWidths = "35;60;45;40;65;40" With ListBox2 .Clear .ColumnCount = UBound(colHeaders) + 1 .ColumnWidths = colWidths .Font.Size = 10 .ColumnHeads = True .AddItem For i = 0 To UBound(colHeaders) .List(0, i) = colHeaders(i) Next i End With currentRow = 1 For i = 2 To lastRow If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" Then ListBox2.AddItem ListBox2.List(currentRow, 0) = ws.Cells(i, 1).Value ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value currentRow = currentRow + 1 End If Next i If ListBox2.ListCount = 1 Then MsgBox "لم يتم العثور على نتائج" End If TextBox7.Text = "عدد السجلات في القائمة : (" & ListBox2.ListCount - 1 & ")" Call TOtal End Sub

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى انها عملية بحث بين شرطين او اكثر اسم المخزن وكود الصنف والتاريخ اذا لزم الامر واظهار النتائج فى الليست بوكس 2 وعند عملية البحث لايدرج بيانات رؤوس الاعمدة داخل الليست بوكس2 فما الخطاء فى الكود Private Sub CommandButton1_Click() Dim ws As Worksheet Dim lastRow As Long Dim searchValue1 As String Dim searchValue2 As String Dim currentRow As Long searchValue1 = ComboBox1.Value searchValue2 = ComboBox3.Value Set ws = Worksheets("Sheet3") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' ' تعريف رؤوس الأعمدة وعروضها ' colHeaders = Split("كود", "صنف", "سعر", "كمية المخزون", "اسم المخزن", "تاريخ نهاية الصنف") ' 'colHeaders = Array("اسم المخزن", "كود", "صنف", "سعر", "كمية المخزون", "تاريخ نهاية الصنف") colWidths = "40;50;50;40;60;40" ' تهيئة ListBox2 With ListBox2 .Clear '.columnCount = UBound(colHeaders) + 1 ' عدد الأعمدة + 1 لرأس العمود .columnWidths = colWidths .columnCount = 6 .Font.Size = 10 .ColumnHeads = True ' تعيين رؤوس الأعمدة بشكل صريح (اختياري) ' For i = 0 To UBound(colHeaders) ' ' .List(.ListCount - 1, i) = colHeaders(i) ' ListBox2.AddItem colHeaders(i) ' Next i End With 'ListBox2.Clear currentRow = 0 For i = 2 To lastRow If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" Then ListBox2.AddItem ws.Cells(i, 1).Value ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value currentRow = currentRow + 1 End If Next i If ListBox2.ListCount = 0 Then MsgBox "لم يتم العثور على نتائج" End If End Sub عملية بحث بشرطين او اكثر.xlsm

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