محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFS(A1="","",A1=0,"لا توجد بضاعة",A1<=999,99,"المخزون على وشك النفاد",A1>=1000,"المخزون متوفر") 'OR =IF(A1=0,"لا توجد بضاعة",IF(A1<=999,99,"المخزون على وشك النفاد",IF(A1>=1000,"المخزون متوفر"))) example.xlsx

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

في هده الحالة سيتم الاستغناء عن عناصر label وتعويضها بالصور ضع الكود التالي في Module Option Explicit Public IM() As New Classe1 Sub USF() Dim c As Control, n% With UserForm7 For Each c In .Controls If TypeName(c) = "Image" Then ReDim Preserve IM(n) Set IM(n).IM = c n = n + 1 End If Next End With End Sub وفي Classe Module Option Explicit Public WithEvents IM As MSForms.Image Private Sub IM_Click() Dim c As Control For Each c In IM.Parent.Parent.Controls If TypeName(c) = "Frame" Then c.BackColor = RGB(255, 255, 255) Next 'Yellow IM.Parent.BackColor = RGB(255, 255, 0) 'Red..........= RGB(255,0,0) End Sub مع تعديل الاكواد التالية بعد حدف عناصر label Private Sub UserForm_Initialize() For c = 1 To 4 Me("Image" & c).Visible = False Next End Sub '*********************** Private Sub UserForm_Activate() Call USF With Me .startUpPosition = 3 .Width = Application.Width .Height = Application.Height .Left = 0 .Top = 0 End With End Sub ملاحظة Private Sub Workbook_Open() 'تم تعطيل الكود ليتمكن الجميع من الاستفادة Application.DisplayAlerts = False Application.Visible = False 'If Date >= DateValue("15/06/2024") Or Sheets("names").Range("zz1") = "eta" Then 'Sheets("names").Range("zz1") = "eta" 'MsgBox "call me 00201113135517" 'ThisWorkbook.Save 'Application.Quit 'Else UserForm7.Show 'End If End Sub 2.xlsb

هل تقصد انك قمت باستبدال عناصر label بالصور ارفق ملفك مع الصور المرغوب اظافتها مع تحديد مكان تواجدها لنتمكن من تعديل الكود بما يتناسب مع الوضع الحالي

For c = 1 To 2 For j = 3 To 4 Me("Label" & c).Left = (Me.Width / 1.5) - (Me("Label" & c).Width / 1.5) Me("Label" & j).Left = (Me.Width / 2) - (Me("Label" & j).Width / 1.6) Next Next يمكنك تعديله بالشكل التالي مع التلاعب قليلا بالمكان الاصلي لعناصر label على اليوزرفورم 1.rar

تفضل اخي Private Sub UserForm_Activate() With Me .startUpPosition = 3 .Width = Application.Width .Height = Application.Height .Left = 0 .Top = 0 End With For c = 1 To 4 Me("Label" & c).Left = (Me.Width / 1.8) - (Me("Label" & c).Width / 2.4) Next End Sub 1.rar

وعليكم السلام ورحمة الله تعالى وبركاته يصعب التعامل مع الكود بدون ارفاق الملف لاكن حاول تجربة شيء كهدا Private Sub UserForm_Activate() Me.Label1.Left = (Me.Width / 2) - (Me.Label1.Width / 2) Me.Label2.Left = (Me.Width / 2) - (Me.Label2.Width / 2) Me.Label3.Left = (Me.Width / 2) - (Me.Label3.Width / 2) Me.Label4.Left = (Me.Width / 2) - (Me.Label4.Width / 2) End Sub 'OR Private Sub UserForm_Activate() For c = 1 To 4 Me("Label" & c).Left = (Me.Width / 2) - (Me("Label" & c).Width / 2) Next End Sub test.xlsm

جرب احدى المعادلات التالية 1) =IFERROR(INDEX($C$5:$C$10000;MATCH(2;1/($C$5:$C$10000<>"")));"") 2) =IFERROR(LOOKUP(2;1/($C$5:$C$1000<>"");$C$5:$C$1000);"") 3)قيمة رقمية =IFERROR(LOOKUP(9E+307;C:C);"") mdrrsah.xlsx

ولك بالمثل اخي لقد لاحظت ان الاعمدة الاخيرة تتضمن روابط المقاطع على اليوتيوب والفايس اليك تحديث الكود لتتمكن من نسخ Hyperlinks المواقع والانتقال اليها عبر الوورد Public Property Get n() As Worksheet: Set n = Worksheets("WordCopy") End Property Sub Copy_Transfer_WORD1() Dim arr() As String: Dim cnt() As String Dim lastRow As Long: Dim rngA As Variant: Dim rngB As Variant Dim OneRng As Range: Dim tmp As Range: Dim Ary As Variant Dim i As Long: Dim r As Integer: Dim x As Long: Dim j As Range Application.DisplayAlerts = False Application.ScreenUpdating = False Set WS = Worksheets("Sheet1") n.Visible = xlSheetVisible: n.Cells.UnMerge n.Range("A1:J" & n.Rows.Count).Clear lige = 7 lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row cnt() = Split("I-H,J-I", ",") rngA = Array(1, 3, 4, 5, 6, 7, 8) rngB = Array(1, 2, 3, 4, 5, 6, 7) For i = 0 To UBound(rngA) With WS Set OneRng = .Range(.Cells(lige, _ rngA(i)), .Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy n.Cells(1, _ rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats End With Next i For r = 0 To UBound(cnt): arr = Split(cnt(r), "-") WS.Range(arr(0) & "8:" & arr(0) & lastRow).Copy Destination:=n.Cells(2, arr(1)) Next r lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row Set tmp = n.Range("A1:J" & n.Rows.Count) Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr) a.RowHeight = 75: a.Font.Bold = True: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14: d.Font.Size = 24 d.Merge: d.Interior.Color = RGB(192, 192, 192): n.[A2:I2].Interior.Color = RGB(215, 238, 247) With E .Font.Name = "AdvertisingBold": .Font.Size = 13 .WrapText = True: .MergeCells = False End With F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15) For x = 0 To UBound(Ary) n.Columns(x + 1).ColumnWidth = Ary(x) Next x Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp)) For Each j In Irow.Rows If j.RowHeight < 20 Then: j.RowHeight = 35: Else j.EntireRow.AutoFit Next With tmp .EntireColumn.HorizontalAlignment = xlCenter .EntireColumn.VerticalAlignment = xlCenter End With With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With WS.Activate: ExcelToWordSheet1 n.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 2024 final V3.xlsm

تفضل اخي الكريم 2024 final V2.xlsm

ضع الكود التالي في حدث ورقة Sheet1 سيتم تحديث التسلسل عند اظافة صف او حدفه . وعند كتابة تاريخ جديد في عمود C Private Sub Worksheet_Change(ByVal Target As Range) Dim I As Integer, lastRow As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.EnableEvents = False Application.ScreenUpdating = False With Target Select Case .Column Case 1, 3 If .Row > 8 Then WS.Range("A9:A" & WS.Rows.Count).ClearContents lastRow = WS.Range("C" & WS.Rows.Count).End(xlUp).Row For I = 9 To lastRow WS.Range("A" & I).Value = Val(WS.Range("A8")) + I - 8 Next I End If End Select End With Application.ScreenUpdating = True Application.EnableEvents = True End Sub اما بخصوص عكس التاريخ ليس له علاقة بالكود المشكلة عندك في تنسيق الملف ان شاء الله اول ما اتفرغ ساحاول تعديل طريقة نسخ البيانات لتتناسب مع طلبك ادا لم يسبقني احد الاخوة في دالك 2024 final DATE.xlsm

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

في حالة الرغبة باستخدام الكود الخاص بك يكفي تعديله فقط على الشكل التالي Sub PDF() Dim Path As String Path = Label2.Caption 'Code......................... ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ Path & "ملف رواتب الموظفين\" & fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب هدا Private Sub CommandButton1_Click() Dim WS As Worksheet: Set WS = Sheet3 Dim FileName As String, strDirname As String, Patch As String, strDefpath As String strDirname = Me.TextBox1.Text FileName = WS.[B8] strDefpath = Label2.Caption lr = WS.Range("B" & WS.Rows.Count).End(xlUp).Row WS.PageSetup.PrintArea = "A1:D" & lr + 5 On Error Resume Next If FileName = "" Then MsgBox "يرجى اظافة اسم الملف": Exit Sub If Not Right(strDefpath, 1) = "\" Then strDefpath = strDefpath & "\" If Not Right(FileName, 4) = ".Pdf" Then FileName = FileName & ".Pdf" If Dir(strDefpath & strDirname, vbDirectory) = "" Then MkDir strDefpath & strDirname Patch = strDefpath & strDirname & "\" & FileName WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Patch End Sub ملف V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته المفروض اخي @Alaa Ammar New ورقة الاشطة خاصة بفلترة البيانات بين تاريخين يتم تحديدهم مسبقا في الخلية D2 و F2 بمعنى انت من تحدد البيانات الظاهرة عليها .في حالة الرغبة بجلب جميع البيانات يمكنك فقط تحديد اول واخر تاريخ لديك على Sheet1 يمكنك اظافة الكود التالي في حدث Sheet1 ليتم تحديث التسلسل تلقائيا . Private Sub Worksheet_Change(ByVal Target As Range) Dim sht As Worksheet: Set sht = Sheets("Sheet1") If Target.Column = 1 Then Application.ScreenUpdating = False Application.EnableEvents = False sht.Range("A9:A" & sht.Rows.Count).ClearContents sht.[A9].Value = 1 With sht.Range("A9:A" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row) .Formula = "=Row() - 8" .Value = .Value End With Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub Dim desWS As Worksheet: Set desWS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = printing Application.ScreenUpdating = False If Sheets("Sheet1").TextBox1.Text = "" Then: MsgBox "يرجى اظافة معيار الفلترة": Exit Sub rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000")) If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", _ vbInformation, "تم إلغاء الإجراء": Exit Sub dest.Visible = xlSheetVisible Set a = desWS.Range("A7", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 12 Set a = Union(a, Intersect(a.EntireRow, a.Columns(r))) Next r Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name) If Msg <> vbYes Then Exit Sub dest.Range("A2:L" & dest.Rows.Count).Clear a.Copy Destination:=dest.Range("A6") dest.Range("a8").Value = 1 With dest.Range("a8:a" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Formula = "=Row() - 7" .Value = .Value End With 'حفظ PDF Save_As_PDF2 On Error Resume Next desWS.AutoFilter = False Sheets("Sheet1").TextBox1.Text = "" Application.ScreenUpdating = True 2024 final.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ضع الكود التالي في Module Function arr(a, b) maxtab1 = UBound(a) Dim tmp(): ReDim tmp(1 To UBound(a) + UBound(b), 1 To UBound(a, 2)) For i = LBound(a) To UBound(a) For c = 1 To UBound(a, 2): tmp(i, c) = a(i, c): Next Next i For i = 1 To UBound(b) For c = 1 To UBound(b, 2): tmp(maxtab1 + i, c) = b(i, c): Next Next i arr = tmp End Function وفي داخل اليوزرفورم Dim rng(), Cnt, Width, OneRng, ColVisu '09/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Private Sub UserForm_Initialize() Dim Cpt, F Cpt = [Data]: F = [Data1]: rng = arr(Cpt, F) 'Merge table data For i = LBound(rng) To UBound(rng): rng(i, 2) = Format(rng(i, 2), "dd/mm/yyyy"): Next i OneRng = "Data" Width = Array(100, 80, 80, 160, 80, 60) ColVisu = Array(6, 5, 4, 3, 2, 1): Cnt = UBound(ColVisu) + 1 For c = 1 To Cnt tmp = Range(OneRng).Offset(-1).Item(1, c) Me("Label" & c).Caption = tmp: Me("Labtxt" & c).Caption = tmp Next txtClear Me.ListBox1.ColumnCount = Cnt Me.ListBox1.ColumnWidths = Join(Width, ";") Dim result(): n = 0 For i = 1 To UBound(rng) n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each k In ColVisu c = c + 1: result(c, n) = rng(i, k) Next k Next i If n > 0 Then Me.ListBox1.Column = result: Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If End Sub '***************** Sub filterdata() Dim result(): n = 0 Dim Cpt1 As String, Cpt2 As String For i = 1 To UBound(rng) 'الاسم If TextBox1.Value = "" Then Cpt1 = rng(i, 3) Else Cpt1 = "*" & TextBox1.Value & "*" 'رقم المعاملة If TextBox2.Value = "" Then Cpt2 = rng(i, 6) Else Cpt2 = "*" & TextBox2.Value & "*" If LCase(rng(i, 3)) Like LCase(Cpt1) And LCase(rng(i, 6)) Like LCase(Cpt2) Then n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each r In ColVisu c = c + 1: result(c, n) = rng(i, r) Next r End If Next i If n > 0 Then Me.ListBox1.Column = result Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If txtClear End Sub '*********************** Private Sub TextBox1_Change() Call filterdata End Sub Private Sub TextBox2_Change() Call filterdata End Sub Private Sub ListBox1_Click() For i = 1 To Cnt Me("txt" & i) = Me.ListBox1.Column(i - 1) Next i End Sub '********************* Private Sub transfert_Click() Set WS = Sheets("Sheet1") WS.Cells.ClearContents n = ListBox1.ListCount: result = Me.ListBox1.List WS.[A2].Resize(n, 6) = Application.Index(result, _ Evaluate("Row(1:" & n & ")"), ColVisu) c = 0 For c = 1 To Cnt WS.Cells(1, c) = Range(OneRng).Offset(-1).Item(1, c) Next Me.TextBox1 = "": Me.TextBox2 = "" MsgBox "تم ترحيل البيانات بنجاح", Exclamation, "admin" End Sub '************************* Sub txtClear() For k = 1 To Cnt Me("txt" & k) = "" Next k End Sub كشف المعاملات المؤرشفة.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اظن ان الصيغة الصحيحة للسؤال هي حساب عدد الاختلافات جرب وضع احدى المعادلات التالية في الخلية E2 =SUM(IFERROR(1/COUNTIFS($D$5:$D$200;$D$5:$D$200;$F$5:$F$200;D2);0)) OR =IFERROR(SUM(IF(D2=$F$5:$F$200;1/(COUNTIFS($F$5:$F$200;D2;$D$5:$D$200;$D$5:$D$200));0));"") التكرار2.xlsx

حساب السن أول 10.xlsx

ولك بالمثل اخي @أبو قاسم يسعدنا اننا استطعنا مساعدتك

جرب هدا SALARY.xlsx

لست متاكدا من طلبك لاكنك ادا كنت تقصد اظهار اسماء اوراق العمل كما في الصورة المدرجة والتنقل بينها جرب هدا يمكنك تعديله بما يناسيك test.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Dim depart, Cnt, comment, f, ColSearch(), J Public Property Get WS() As Worksheet: Set WS = ActiveSheet End Property Private Sub UserForm_Initialize() Dim arr() comment = " تحديد ورقة العمل" Me.Label1.Width = 900 depart = Me.Label1.Left Message = " برنامج المخازن يرحب بكم . صل على محمد" Me.Label1.Caption = "**********" & Message & "**********" & Message & "************" Cnt = Len(Me.Label1.Caption): Me.ComboBox1 = comment ColSearch = Array(3, 2, 1) J = UBound(ColSearch) + 1 For i = 1 To 3: Me("head" & i).Visible = False: Next i k = 1 For Each sh In ActiveWorkbook.Sheets If sh.Cells(3, 3) <> Empty Then ReDim Preserve arr(1 To k) arr(k) = sh.Name k = k + 1 End If Next sh Me.ComboBox1.List = arr Me.ComboBox1.ListIndex = 0 Count.Caption = ListBox1.ListCount Me.ComboBox1 = comment End Sub '*************************************** Private Sub Textbox1_Change() r = "*" & Me.Textbox1 & "*" Dim Cpt(): n = 0 For i = 1 To UBound(f) If f(i, 1) Like r Then ' فلترة بالاسم عمود (1) n = n + 1: ReDim Preserve Cpt(1 To J, 1 To n) c = 0 For Each k In ColSearch c = c + 1: Cpt(c, n) = f(i, k) Next k End If Next i If n > 0 Then Me.ListBox1.Column = Cpt Else Me.ListBox1.Clear Count.Caption = ListBox1.ListCount End Sub '******************************* Private Sub ComboBox1_Change() On Error Resume Next Sheets(CStr(ComboBox1)).Activate f = WS.Range("A3:C" & WS.[a65000].End(xlUp).Row).Value If Me.ComboBox1 <> comment And WS.Cells(3, 3) <> "" Then For i = 1 To 3: Me("Hard" & i).Visible = True: Next i Set d = CreateObject("Scripting.Dictionary") For i = LBound(f) To UBound(f) If f(i, 1) <> "" Then d(i) = Array(f(i, 3), f(i, 2), f(i, 1)) Next i n = d.Count If n > 0 Then Dim Cpt: Cpt = Application.Transpose(d.items) ReDim Preserve Cpt(1 To 3, 1 To n + 1) Me.ListBox1.List = Application.Transpose(Cpt) Me.ListBox1.RemoveItem n For i = 1 To 3: Me("Hard" & i) = WS.Cells(2, i): Next i Count.Caption = ListBox1.ListCount End If End If End Sub يوزر فورم3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بما انك لم تقم باظافة اليوزرفورم تمت اظافته من المشاركة السابقة لك والاشتغال عليه بنفس الفكرة ربما هدا ما تقصده Dim depart, Cnt, comment Private Sub UserForm_Initialize() comment = " تحديد ورقة العمل" Me.Label1.Width = 900 depart = Me.Label1.Left Message = " برنامج المخازن يرحب بكم . صل على محمد" Me.Label1.Caption = "**********" & Message & "**********" & Message & "************" Cnt = Len(Me.Label1.Caption): Me.ComboBox1 = comment End Sub '**************************** Private Sub UserForm_Activate() Me.Label1.Visible = True For x = depart To -(2.8 * Cnt - depart) Step -1 Me.Label1.Left = x w = 0.04 temp = Timer Do While Timer < temp + w DoEvents Loop Next x UserForm_Activate End Sub '*********************** Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) Set dico = CreateObject("Scripting.Dictionary") For Each c In ActiveWorkbook.Sheets dico(c.Name) = "" Next c dico.Remove (ActiveSheet.Name) Me.ComboBox1.List = dico.keys Me.ComboBox1.SetFocus End Sub '*********** Private Sub ComboBox1_Change() On Error Resume Next Sheets(CStr(ComboBox1)).Activate Me.ComboBox1 = comment End Sub يوزر فورم.xlsb

نظرا للطلبات الحالية اظن انه يجب علينا التعديل على اكثر من كود للحصول على النتائج المتوقعة والتعديل كالاتي : Private Sub UserForm_Initialize() 'Code''''''''' '''''''''''''' ' 4اسم المخزن 'Code'''''''''' rw = d.keys ' Sort Combobox 1 Colmun "اسم المخزن" (5) tri rw, LBound(rw), UBound(rw) Me.ComboBox1.List = rw: Me.ComboBox1.ListIndex = 0 'Code'''''''''' 'Sort listbox2 Colmun "الكود" (1) 'القيمة (OneRng, 1) 'ترمز الى رقم العمود الهدف قم بتعديلها بما يناسبك P OneRng, 1, LBound(OneRng), UBound(OneRng) End Sub '******************************** Private Sub ComboBox1_AfterUpdate() 'Code'''''''' Next i rw = j.keys tri rw, LBound(rw), UBound(rw) 'Sort Me.ComboBox2.List = rw Set j = Nothing End Sub '************************************** Sub Filtre() 'Code''''''''''''''''' f.[R2] = Cpt1: f.[S2] = Cpt2 Me.TextBox2 = Format(CStr(f.[X2]), "#,##0.00") If f.[v2] = 0 Then Me.stocktr = f.[U2]: Me.TextBox1.value = Format(f.[W2], "dd/mm/yyyy") Else _ Me.stocktr = f.[V2]: Me.TextBox1.value = Format(f.[T2], "dd/mm/yyyy") 'Code''''''''''''''''' If Me.ComboBox1 = "*" And _ Me.CB_Pièce = "*" Then _ Me.ListBox2.Clear: SubTotal = "": PriceTotal = "": LabelCont = "": TextBox1 = "" End Sub مع نسخ هده الاكواد داخل اليوزرفورم Sub tri(a, gauc, droi) 'Combobox (1-2) ترتيب تصاعدي réf = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < réf: g = g + 1: Loop Do While réf < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '********************** Sub P(a, V, gauc, droi) 'ترتيب البيانات على الليست بوكس بشرط رقم الكود réf = a((gauc + droi) \ 2, V) g = gauc: d = droi Do Do While a(g, V) < réf: g = g + 1: Loop Do While réf < a(d, V): d = d - 1: Loop If g <= d Then For k = LBound(a, 2) To UBound(a, 2) temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp Next k g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call P(a, V, g, droi) If gauc < d Then Call P(a, V, gauc, d) End Sub اظن اننا استطعنا تنفيد طلبك خطوة بخطوة وهدا افضل بكثير من التعديل على اكواد تم انشاءها مسبقا او طلب اكثر من طلب دفعة واحدة لتستطيع فهم طريقة اشتغال ملفك ويسهل عليك التعديل عليه عند الحاجة مستقبلا sell-the-first-quantity- V7.xlsm

Option Compare Text Dim OneRng(), Rng, rCrit1, rCrit2 Public Property Get f() As Worksheet: Set f = Sheets("Stock") End Property Private Sub UserForm_Initialize() OneRng = f.Range("A4:I" & f.[A65000].End(xlUp).Row).value Rng = UBound(OneRng, 2) 'تنسيق التاريخ For i = LBound(OneRng) To UBound(OneRng): OneRng(i, 9) = Format(OneRng(i, 9), "dd/mm/yyyy"): Next i ' تنسيق عمود السعر For i = 1 To UBound(OneRng): OneRng(i, 3) = Format(OneRng(i, 3), "00.00"): Next i 'Code............ Me.ListBox2.ColumnCount = 9 Me.ListBox2.ColumnWidths = "40;55;60;60;60;0;0;0;50" End Sub عند اختيار مخزن معين فى ComboBox1 لايظهره فى هذا المخزن ComboBox2 وانما يظهر المخازن الاخرى Private Sub ComboBox1_AfterUpdate() If Me.ComboBox1 = "*" Then Me.ComboBox2 = "*" Set j = CreateObject("Scripting.Dictionary") j("*") = "" a = f.Range("E4:E" & f.[E65000].End(xlUp).Row) For i = LBound(a) To UBound(a) If (a(i, 1) <> "") And (Format(a(i, 1), "@") <> Me.ComboBox1.value) Then j(a(i, 1)) = "" Next i Me.ComboBox2.List = j.keys Set j = Nothing End Sub sell-the-first-quantity- V5.xlsm