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

تفضل اخي ضع هدا في موديول Sub GetPrice2() Dim WSPrice As Worksheet, dest As Worksheet, ws As Worksheet, WSitems As Worksheet Dim LASTROW&, Dest_Last&, Cpt&, DataRow&, destRow&, I&, derlig&, Z& Dim Clé As Object, dictKey As String, Price_list As String Dim srcRng As Range, KeyRng As Range, Dest_Rng As Range Dim Col As Variant, f As Variant, Réf As Variant Dim ShtDate As Date, MaxDate As Date, Title As Range Dim XPric As Range, XROW As Range, S As Range With Application .EnableEvents = False .ScreenUpdating = False Set dest = Worksheets("itemout") Set WSitems = ThisWorkbook.Sheets("items") Set XPric = dest.[E4]: Set Title = dest.[B8:B32]: Price_list = dest.[B4].Value If Price_list = "" Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub If XPric = "" Then: MsgBox "يجب عليك إدخال نوع التعامل", vbInformation: Exit Sub If Len(Price_list) > 0 Then If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= Price_list And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & Price_list & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) With WSPrice If WSPrice.FilterMode Then WSPrice.ShowAllData DataRow = 5 LASTROW = .Range("D" & .Rows.Count).End(xlUp).Row Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(LASTROW, "J")) Col = srcRng.Value2 End With For Z = 8 To 32 Union(dest.Range("A" & Z), dest.Range("C" & Z), dest.Range("G" & Z), dest.Range("H" & Z)).ClearContents Next Z With dest destRow = 8 Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row Set KeyRng = .Range(.Cells(destRow, "B"), .Cells(Dest_Last, "F")) f = KeyRng.Value2: Set Dest_Rng = .Cells(destRow, "G") ReDim Réf(1 To UBound(f, 1), 1 To 1) End With Set Clé = CreateObject("Scripting.dictionary") For I = 1 To UBound(Col) dictKey = Col(I, 1) If Not Clé.exists(dictKey) And (dictKey) <> "" Then Clé(dictKey) = I End If Next I For I = 1 To UBound(f) dictKey = f(I, 1) If Clé.exists(dictKey) Then Cpt = Clé(dictKey) Set XROW = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, LookAt:=xlWhole) If Not XROW Is Nothing Then For Frow = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row Set B = WSitems.Cells.Find(What:=dest.Range("B" & Frow), LookAt:=xlPart) If Not B Is Nothing And B <> "" Then dest.Range("C" & Frow) = B.Offset(0, 1).Value Next Frow Réf(I, 1) = WSPrice.Cells(Cpt + 4, XROW.Column) Else MsgBox "نوع التعامل غير موجود" Exit Sub End If End If On Error Resume Next Next I Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf End If End If End If For Each S In Title If S.Value <> "" Then J = J + 1 S.Offset(0, -1).Value = Format(J, "0") End If Next derlig = dest.Range("B" & dest.Rows.Count).End(xlUp).Row With dest.Range("H8:H" & derlig) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With .EnableEvents = True .ScreenUpdating = True dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name End With End Sub وهدا في حدث ورقة itemout Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Target.Worksheet.Range("E4")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Application.EnableEvents = False Call GetPrice2 End If If Intersect(Target, Range("B8:B32,F8:F32,H8:H32")) Is Nothing Then Exit Sub Call GetPrice2 Application.EnableEvents = True On Error GoTo 0 End Sub price list officena V3.xlsm

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

اخيرا تم المطلوب بمساعدة الاستاذ/ foksh فقد قام باخلاقة واحترامه بمساعدتى واتم الموضوع كله على خير والمشكلة كانت فى نسخة اوفيس عندى ناقص فيها اشياء كثيرة وقمت بتحميل نسخة جديدة وظهر عندى كل شئ بارك الله فى الاستاذ/ foksh والهم بارك فى صحته وعافيته واسرته

جرب غير السطرين بهذين Dim db As DAO.Database Dim t As DAO.TableDef

استاذ محمد هشام بارك الله فيك وزادك من فضلة ومن علمه وعلمك ما لم تعلم كفيت ووفيت يا اخي صعنت ما طلبته وطورت الملف ايضا بشكل افضل مما وددت فلله الحمد ولك الثناء والشكر وافر التحية والاحترام اخي الكريم

بالنسبة لي عدة نقاط منها :- تجنب ارفاق المرفقات داخل قاعدة البيانات . تجنب المسميات للحقول والمكونات والعناصر باللغة العربية ( ودي الحاجة اللي انا شخصياً تأكدت منها عن تجربة شخصية وقعت فيها ) . تكرار الاكواد . إجبار قاعدة البيانات على العمل بما يسبب ضغطها ( كوظائف تتعلق بتغيير اعدادات نظام الويندوز ..... إلخ ) بفضل استخدام تقسيم قاعدة البيانات للجداول بحيث يكون تخزين البيانات منفصل عن النماذج والتقارير .... إلخ ، لتخفيف الضغط مستقبلاً عند تضخم حجم البيانات . نقاط كثيرة قد يذكرها أساتذتنا في المنتدى .. هذا من وجهة نظري

مشاركة مع اساتذتي الكرام ........ استبدلها بهذا فقط =Int(DateDiff("d";[date_naissance];Date())/365.25)

مشاركة مع اخي الاستاذ @محمد احمد لطفى في حدث عند تحميل النموذج ضع هذا الكود ... مع مسح الدالة الموجودة في مربع نص العمر بالسنوات Dim intH, years As Integer intH = Int(DateDiff("m", date_naissance, Date)) + _ (Date < DateSerial(Year(Date), Month(Date), Day(date_naissance))) years = Int(intH / 12) نص22 = years

وعليكم السلام ورحمة الله ..... اولا : تحتاج ثلاث مخازن طبعا اقصد برمجيا ( مخزن للمواد الخام - مخزن للإنتاج - مخزن مستودع للتوزيع ) ... وكل مخزن من هذه المخازن يعتبر مخزن مستقل اي تكون لها كل الجداول والنماذج والتقارير الخاصة بها ... ( موردين _ اصناف _ مشتريات _ إلخ ) ثانيا : تدخل المواد الخام في مخزن المواد الخام .... وكذلك المنتجات فمثلا ( منتج مربى توت ) >>>> تقدر لها بالتفصيل ما يحتاجه هذا المنتج على مستوى ( العلبة - الكرتون - الطبلية مثلا ) من مواد خام ( مثلا سكر 250 جرام - توت 250 جرام - برطمان أو قارورة واحدة .... وهكذا ) هذا بالنسبة للعلبة واذا كانت الوحدة كرتون نفس الطريقة ........... ثالثا : يتم استيراد المواد الخام من خلال مخزن المواد الخام >>>>> ثم تصديرها الى مخزن الإنتاج بالاليه المذكورة سابقا يعني ( كم عدد الطبليات المطلوب انتاجاها مثلا 100 طبلية ) اذن كم من المواد الخام المطلوبة للإنتاج حسب ما هو مسجل مسبقا في جدول برنامج مخازن المواد الخام >>>>> بعد ان يتم تسلمها وقيدها في برنامج مخزن الإنتاج >>> تم التصنيع >>> يتم نقلها الى برنامج مخزن التخزين ( المستودع ) ليتم التوزيع ايضا بآلية التوزيع في المستودعات ( هذا بشكل سريع للآليات ان لم انس شيئا منها .... والله أعلم ) بالتوفيق ..

شكرا استاذنا لك مني جزيل الشكر و الاحترام