محمد هشام.

تفضل اخي المسالة ليس لها علاقة بالكود التاريخ يتم احتسابه عن طريق معادلة . Book_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي Dim H, BT(), Rng, Ncol, MH1(), MH2(), MH3 Private Sub UserForm_Initialize() Set H = Sheets("BT") Set Rng = H.Range("A6:H" & H.[A65000].End(xlUp).Row) MH2 = Array(2, 3, 4, 5, 6) MH1 = Array(2, 3, 6, 4, 5) MH3 = 1 BT = Rng.Value Ncol = UBound(MH1) + 1 Me.ListBox1.ColumnWidths = temp & ";150" For i = Ncol + 1 To 5: Me("textbox" & i).Visible = False: Next i Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(BT) To UBound(BT) d(BT(i, MH3)) = "" Next i temp = d.keys Me.ComboBox1.List = temp Me.ComboBox1 = "*" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub B_résultat_Click() Set MH = Sheets("التصفية") MH.Range("B10:F100").ClearContents A = Me.ListBox1.List MH.[b10].Resize(UBound(A) + 1, UBound(A, 2) + 1) = A With ThisWorkbook.Worksheets("التصفية") Sheet4.Range("c3") = ComboBox1.Text .Range("c5").Value = CDate(Me.TextBox2.Value) .Range("c7").Value = CDate(Me.TextBox3.Value) End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboBox1_Change() Sheet3.Range("P2") = ComboBox1.Text TextBox1.Value = Sheets("BT").Range("Q2").Value TextBox2.Value = Sheets("BT").Range("R2").Value TextBox3.Value = Sheets("BT").Range("S2").Value Dim Tbl(): ReDim Tbl(1 To Ncol + 1, 1 To UBound(BT)) ligne = 0 For i = 1 To UBound(BT) If BT(i, MH3) Like Me.ComboBox1 Then ligne = ligne + 1 c = 0 For Each k In MH1 c = c + 1: Tbl(c, ligne) = BT(i, k) Next k ' c = c + 1: Tbl(c, ligne) = i + Decal End If Next i ReDim Preserve Tbl(1 To Ncol + 1, 1 To ligne) Me.ListBox1.Column = Tbl End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub TriS(A, gauc, droi) ref = A((gauc + droi) \ 2) g = gauc: d = droi Do Do While A(g) < ref: g = g + 1: Loop Do While ref < 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 TriS(A, g, droi) If gauc < d Then Call TriS(A, gauc, d) End Sub Book_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي الكريم Private Sub CommandButton1_Click() Dim filePath As String Dim Ws As Worksheet Application.ScreenUpdating = False filePath = Application.ActiveWorkbook.Path Set Ws = Sheets("بيانات") With Ws .Copy Application.DisplayAlerts = False Application.CutCopyMode = False Dim shape As Excel.shape For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & .Name & "" & "" & ".xlsx", FileFormat:=51 Application.ActiveWorkbook.Close False End With MsgBox "تم نسخ الملف بنجاح" Application.ScreenUpdating = True End Sub wor_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته بالنسبة للكود يمكنك جعله بهده الطريقة اخي الكريم وسبب تاخيري عن الرد على طلبك هو انني كنت انتظر جوابك بخصوص كود المنتج لاكن للاسف جوابك غير مفهوم (كود المنتج يكتب آليا ) تتضمن عدة امور Private Sub CommandButton10_Click() If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("b:b"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If With ActiveSheet If .FilterMode Then .ShowAllData lr = .Cells(Rows.Count, 1).End(3).Row + 1 Cells(lr, 1).Resize(, 4) = Array(lr - 1, txt_product, txt_price_sale, txt_price_pru) End With Me.txt_product.Value = "" Me.txt_price_sale.Value = "" Me.txt_price_pru.Value = "" MsgBox "Done", vbtnformation End Sub اما الزيادة التي سبق ان وعدتك بها في المشاركة السابقة هي عبارة عن ملفك يتضمن جميع الاظافات التي من الممكن ان تحتاجها . ترحيل _ تعديل _ حدف _ بحث بكود المنتج Private Sub CommandButton9_Click() '''''''''ترحيل البيانات''''''''' ''الشرط الاول'' If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If ''الشرط الثاني'' If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If ''الشرط الثالث'' If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If ''التحقق من وجود اسم المنتج مسبقا '' Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("B:B"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If ''''''''''' النطاق المرحل اليه'''''''''''' Dim lr As Long lr = Sheets("product_master").Range("B" & Rows.Count).End(xlUp).Row With sh .Cells(lr + 1, "b").Value = Me.txt_product.Value .Cells(lr + 1, "c").Value = Me.txt_price_pru.Value .Cells(lr + 1, "d").Value = Me.txt_price_sale.Value End With ''''''''افراغ textbox''''''' Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" ''''''''(A)ترقيم تلقائي لعمود '''''' ''مع امكانية حدف الصفوف '' Worksheets("product_master").Activate Application.EnableEvents = False With Range("a2:a" & Cells.Find("*", , , , xlByRows, xlPrevious).Row) .Formula = "=Row() - 1" .Value = .Value End With Application.EnableEvents = True MsgBox "تم الترحيل بنجاح", vbtnformation '' UserForm_تحديث '' Unload Me frm_product_master.Show End Sub '''''''''' البحث بكود المنتج'''''''''''' Private Sub CommandButton10_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then txt_product = Sheets("product_master").Cells(y, 2).Value txt_price_pru = Sheets("product_master").Cells(y, 3).Value txt_price_sale = Sheets("product_master").Cells(y, 4).Value End If Next y End Sub ''''''''''''''''تعديل البيانات'''''''''''''''' Private Sub CommandButton12_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Sheets("product_master").Cells(y, 2).Value = txt_product Sheets("product_master").Cells(y, 3).Value = txt_price_pru Sheets("product_master").Cells(y, 4).Value = txt_price_sale End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم التعديل بنجاح", vbInformation End Sub ''''''''''''''''حدف صف معين'''''''''''''''' Private Sub CommandButton13_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Rows(y).Delete End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم حدف البيانات بنجاح", vbInformation Call MH Unload Me frm_product_master.Show End Sub ''''''''''''''''UserForm _ تحديث واجهة '''''''''''''''' Sub Refresh_data() Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") Dim lr As Long lr = Sheets("product_master").Range("a" & Rows.Count).End(xlUp).Row If lr = 1 Then lr = 2 With Me.ListBox .ColumnCount = 4 .ColumnHeads = True .RowSource = "product_master!A2:d" & lr End With End Sub Private Sub CommandButton14_Click() If MsgBox("هل تريد الخروج من البرنامج", vbQuestion + vbYesNo, "Confirmation") = vbYes Then Unload Me End If End Sub Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean) txtSearch.Text = ListBox.Column(0) If txtSearch.Text = Me.ListBox.Column(0) Then Me.txt_product = Me.ListBox.Column(1) Me.txt_price_pru = Me.ListBox.Column(2) Me.txt_price_sale = Me.ListBox.Column(3) End If End Sub المحل_MH.xlsm

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

السؤال هل هناك رقم او رمز معين لكود المنتج او ترقيم تلقائي 1.2.3 إلى آخره

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

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي تم اضافة كود الفاتورة للصفحات الاربعة AA.xlsm

وعليكم السلام ورحمة الله وبركاته اتبع الخطوات التالية اخي https://streamable.com/yuhc88

العفو اخي الكريم تفضل هدا حل اخر Public Sub Filter_data() Dim lo As ListObject, rng As Range Dim rw As Long, i As Long Dim arrayCriteria() Set lo = Range("T_ID").ListObject rw = lo.ListRows.Count ReDim arrayCriteria(rw) For i = 1 To rw arrayCriteria(i) = CStr(lo.DataBodyRange.Cells(i, 1)) Next i Set rng = Range("T_data") With rng.ListObject If .ShowAutoFilter Then .AutoFilter.ShowAllData .Range.AutoFilter field:=1, Criteria1:=arrayCriteria, Operator:=xlFilterValues End With End Sub فلترة بنطاق معين.xlsm

الشيت غير مفهوم حاول وضع نموذج او عينة للنتائج المتوقعة

tb10 قيمه الفاتورة AAAAA(1).xlsm

تقصد نضيف الكود ترحيل tb10 إلى عمود K

موجودة في أي مكان؟

تفضل اخي مع اضافة كود زر الخروج AAAAA(1).xlsm

تفضل اخي قدتم حل مشكلة اختفاء مربعات التحرير عن الغاء تفعيل CheckBox3 AAAAA(1).xlsm

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

أخي قم بتحميل الملف الأخير قد تم تعديل شرط CheckBox3 أما بالنسبة لكود الفاتورة أن شاء الله سوف أحاول إنشاءه باذن الله

تفضل اخي لكي تفهم الموضوع اكثر تم اضافة ظهور قيمة الضريبة بمجرد كتابة المبلغ والعدد لكي نتمكن من نسخها الى تكست بوكس 1 وبالتالي يتم ترحيلها الى الشيت الكود السابق يعتمد على ظهور قيمة الضريبة عند الظغط على زر اضافة فقط وبهذا عند تنفيد الكود سوف يجد تكست بوكس (bt8) فارغة !!!!!!!!!! AAAAA(1).xlsm

السلام عليكم اخي لقد لاحظت انه عند كل ترحيل جديد يتم مسح البيانات القديمة هل هي عن قصد ؟

السلام عليكم ورحمة الله وبركاته ..جرب أخي هل هذا هو المطلوب AAAAA(1).xlsm

تفضل اخي لاكن الترتيب حسب اوراق العمل تم اضافة الاكواد التالية كود لترتيب التاريخ من الاصغر للاكبر يتم تفعيله تلقائيا عند الدخول على اليوزفورم. Sub MH_sort() Dim ws As Worksheet Application.ScreenUpdating = False Dim LR As Long For Each ws In ThisWorkbook.Worksheets LR = ws.Range("b" & ws.Rows.Count).End(xlUp).Row If (ws.Name <> "Database") Then With ws.Sort .SortFields.Clear .SortFields.Add2 Key:=ws.Range("e5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange ws.Range("b4:L" & LR) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End If Next ws Sheets("المبيعات").Activate Range("A1").Select وهدا لالغاء الفراغ الموجود في ComboBox1 Private Sub UserForm_Initialize() Dim I As Integer With Sheets("Database") For r = 2 To .Range("c" & .Rows.Count).End(xlUp).Row If .Range("c" & r) <> "" Then ComboBox1.AddItem .Range("c" & r) End If Next r End With End Sub AAAAA.xlsm

تفضل اخي جرب 'Option Explicit Private Sub ComboBox1_Change() Sheet2.Range("s1") = ComboBox1.Text TextBox1.Value = Sheets("المبيعات").Range("R1").Value Dim a Dim i As Long Me.ComboBox1.Text = StrConv(Me.ComboBox1.Text, vbProperCase) Me.ListBox1.Clear For Each ws In ActiveWorkbook.Sheets With ws For i = 5 To Application.WorksheetFunction.CountA(.Range("b:b")) a = Len(Me.ComboBox1.Text) If Left(.Cells(i, 8).Value, a) = Left(Me.ComboBox1.Text, a) Then Me.ListBox1.AddItem .Cells(i, 1).Value Me.ListBox1.List(ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value Me.ListBox1.List(ListBox1.ListCount - 1, 2) = .Cells(i, 3).Value Me.ListBox1.List(ListBox1.ListCount - 1, 3) = .Cells(i, 5).Value Me.ListBox1.List(ListBox1.ListCount - 1, 4) = .Cells(i, 6).Value Me.ListBox1.List(ListBox1.ListCount - 1, 5) = .Cells(i, 8).Value Me.ListBox1.List(ListBox1.ListCount - 1, 6) = .Cells(i, 9).Value End If Next i End With Next ws End Sub '''''''''''''''''''' Private Sub CommandButton1_Click() Dim z As Control For Each z In UserForm1.Controls If TypeName(z) = "TextBox" Then z.Value = "" ListBox1.Clear End If Next z End Sub '''''''''''''''''''' Private Sub CommandButton2_Click() Dim ctl As Control For Each ctl In Me.Controls Select Case TypeName(ctl) Case "ComboBox", "TextBox" ctl.Text = "" End Select Next ctl End Sub '''''''''''''''''''' Private Sub Exitbutton_Click() UserForm1.Hide End Sub AAAAA.xlsm

اخي الفاضل نكمل خطوة خطوة وان شاء الله سوف يتم المطلوب اولا هل هدا هو الشكل النهائي لليوزرفورم تم ترتيب الاعمدة على حسب ما جاء في الشرح داخل الملف وادا كان هناك تغيير اشر اليه

تمام بالنسبة لتكست بوكس ...اما بالنسبة للاعمدة الاولى لاحظت انك شطبت عليها هل سيتم حدفها !!!!!