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

شرح للكود Private Sub Worksheet_Change(ByVal Target As Range) ' الكود هنا مبني على اساس التغيير في اي خلية بالصفحة 'C1 يضاف شرط فقط اذا كانت الخلية المعنية بالامر هي If Target.Address = "$C$1" Then ' G1 اذا كانت الخلية الهدف يقصد بها تساوي الاسم المقصود الذي ذكر في My_name = Range("c1").Value If My_name = Cells(1, "g") Then ' يتم تغيير لون الخلفية للخلية المجاورة للون الاصفر Target.Offset(0, 1).Interior.ColorIndex = 6 Else 'اذا لم يكن ذلك يكون لون الخلفية عادي Target.Offset(0, 1).Interior.ColorIndex = xlColorIndexNone End If End If End Sub

مجدداً بعض المعادلات التي تتعلق بالتاريخ عسى ان تنال الاعجاب exacte d m y.rar

السلام عليكم عملي كله معتمد على: لتسهيل الامر ، اضفت الى النموذج زر: أ. اذا النموذج الفرعي فارغ ، فعند النقر على الزر فانه يضيف 5 سجلات فيه حسب ما وضحت انت ، ولا يعمل الزر اذا كان فيه سجلات ، ب. سواء استخدمت الزر او ادخلت البيانات يدويا بنفس الترتيب (نفس الوجبات ونفس الترتيب) ، فهنا يبدأ الكود في العمل ، مثلا: لا يسمح لك بإدخال سجل سادس ، لا يسمح لك تغيير قيمة حقل الكميات في السجل الرابع والخامس ، عند تغيير قيمة حقل الكميات في اي سجل ، فانه يقوم بعملية الحساب من جديد. هذا كود زر الاضافة: Private Sub cmd_add_5_Click() On Error GoTo err_cmd_add_5_Click Dim rst As DAO.Recordset Dim food_list 'save the Record of the Main Form, if not saved If Me.Dirty Then Me.Dirty = False Set rst = Me.main.Form.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount 'this should be a new set, make sure we don't have Records If RC <> 0 Then MsgBox "لا يمكن الاضافة ، توجد سجلات مسبقا" & vbCrLf & _ "Can't add on existing Records" GoTo Exit_cmd_add_5_Click End If food_list = Array("hamor", "zbedy", "nweby", "sheep", "tona") For i = 1 To 5 rst.AddNew rst!cid = Me.ID rst!food = food_list(i - 1) rst.Update Next i Exit_cmd_add_5_Click: rst.Close: Set rst = Nothing Exit Sub err_cmd_add_5_Click: If Err.Number = 3021 Then 'No Records Resume Next ElseIf Err.Number = 3201 Then 'No Record in main Form MsgBox "رجاء تعبئة بيانات النموذج الرئيسي اولا" & vbCrLf & _ "Please fill Main Form first" Resume Exit_cmd_add_5_Click Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub وهذا كود النموذج الفرعي: Private Sub food_AfterUpdate() 'do the calculations for Records 4 and 5 Call Check_Record End Sub Function Check_Record() On Error GoTo err_Check_Record ' If Me.NewRecord = True Then Exit Function If Me.Dirty Then Me.Dirty = False 'DoCmd.RunCommand acCmdSaveRecord Dim food_list Dim rst As DAO.Recordset 'if we have the same list, then DON'T ALLOW CHANGES TO QTY Set rst = Me.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount food_list = Array("hamor", "zbedy", "nweby", "sheep", "tona") Counter = 0 For i = 1 To 5 If rst!food = food_list(i - 1) Then Counter = Counter + 1 End If rst.MoveNext Next i If Counter = 5 Then 'get the 4th and 5th Records values rst.MoveFirst Q1 = rst!qty rst.MoveNext Q2 = rst!qty RQ5 = Q2 / 5 rst.MoveNext Q3 = rst!qty RQ4 = Q1 - (Q3 + RQ5) rst.MoveNext rst.Edit rst!qty = RQ4 rst.Update rst.MoveNext rst.Edit rst!qty = RQ5 rst.Update End If Exit_Check_Record: rst.Close: Set rst = Nothing Exit Function err_Check_Record: If Err.Number = 3021 Then Resume Exit_Check_Record Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function Private Sub Form_Current() On Error GoTo err_Form_Current If Me.NewRecord = False Then Exit Sub Dim food_list Dim rst As DAO.Recordset 'if we have the same list, then DON'T ALLOW CHANGES TO QTY Set rst = Me.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount food_list = Array("hamor", "zbedy", "nweby", "sheep", "tona") Counter = 0 For i = 1 To 5 If rst!food = food_list(i - 1) Then Counter = Counter + 1 End If rst.MoveNext Next i If Counter = 5 Then Cancel = True Me.Undo DoCmd.GoToRecord , , acPrevious MsgBox "لا يمكنك اضافة سجل جديد" & vbCrLf & _ "Can't add a new Record" Exit Sub End If Exit_Form_Current: rst.Close: Set rst = Nothing Exit Sub err_Form_Current: If Err.Number = 3021 Then Resume Exit_Form_Current Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub Private Sub qty_AfterUpdate() 'do the calculations for Records 4 and 5 Call Check_Record End Sub Private Sub qty_BeforeUpdate(Cancel As Integer) On Error GoTo err_qty_BeforeUpdate Dim food_list Dim rst As DAO.Recordset 'if we have the same list, then DON'T ALLOW CHANGES TO QTY Set rst = Me.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount food_list = Array("hamor", "zbedy", "nweby", "sheep", "tona") Counter = 0 For i = 1 To 5 If rst!food = food_list(i - 1) Then Counter = Counter + 1 End If rst.MoveNext Next i If Counter = 5 Then If Me.food = "sheep" Or Me.food = "tona" Then Cancel = True Me.Undo MsgBox "لا يمكنك تغيير قيمة الكمية اذا كانت الوجبة " & vbCrLf & Me.food & vbCrLf & _ "Can't change Qty if food is " & Me.food Exit Sub End If End If Exit_qty_BeforeUpdate: rst.Close: Set rst = Nothing Exit Sub err_qty_BeforeUpdate: If Err.Number = 3021 Then Resume Exit_qty_BeforeUpdate Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 407.قيمة محسوبة.mdb.zip

و ربما يكون هذا الكود مفيداً لأثراء الموضوع Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) last = Cells(Rows.Count, "c").End(xlUp).Row For i = 2 To last Select Case Range("c" & i) Case "المقاولات" Range("d" & i).Font.ColorIndex = 5 Case "العقارات" Range("d" & i).Font.ColorIndex = 3 Case "الصيانة" Range("d" & i).Font.ColorIndex = 8 Case "المالية" Range("d" & i).Font.ColorIndex = 38 End Select Next End Sub

تفضل تم تعديل الكود المسؤول عن فتح النماذج من التعمل مع الحقول الرقمية: =" & Me![PrtyID] الى التعامل مع الحقول النصية : ='" & Me![PrtyID] & "'" ملحوظة لا تفتح نموذج frmNewMstjr مباشرة ولكن افتحه بالنقر المزدوج على اسم العقار في الصفحة الرئيسية AboRami6.rar

ابدعت استاذي الكريم ( ابو عبدالبارى) ..الف شكر يا طيب مع احترامي وتقديري لشخصكم

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

جرب المرفق 2.rar

مشكور لكلماتك الرقيقة الملف يعمل عندي ولكن جرب هذا الملف abo_abary_اضافة ارقام بشرط.rar

ربما يكون هذا الكود اسرع Sub Salim_Tarhil() Dim Source_Sheet, Target_Sheet1, Target_Sheet2 As Worksheet Set Source_Sheet = Sheets("بيانات الممنوحين") Set Target_Sheet1 = Sheets("ممنوح"): Set Target_Sheet2 = Sheets("تجميد") Application.ScreenUpdating = False For i = 1 To Sheets.Count With Sheets(i) .AutoFilterMode = False If .FilterMode = True Then .ShowAllData End With Next Target_Sheet1.Range("a10:m1000").ClearContents Target_Sheet2.Range("a10:m1000").ClearContents Source_Sheet.Range("$A$8:$M$1000").AutoFilter Field:=12, Criteria1:="ناجح" Source_Sheet.Range("$A$9:$M$1000").SpecialCells(12).Copy Destination:=Target_Sheet1.Range("a10") Source_Sheet.Range("$A$8:$M$1000").AutoFilter Field:=12, Criteria1:="راسب" Source_Sheet.Range("$A$9:$M$1000").SpecialCells(12).Copy Destination:=Target_Sheet2.Range("a10") ' Source_Sheet.ShowAllData Application.ScreenUpdating = True End Sub

ربما يكون مفيداً هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 3 And Target.Row < 2 And Target.Count <> 1 Then GoTo 1 Application.EnableEvents = False Target.Offset(0, 1).Font.ColorIndex = xlColorIndexNone With Target.Offset(0, 1).Font Bold = True Italic = True End With With Target.Offset(0, 1).Font Select Case Target.Value Case "المقاولات" .ColorIndex = 5 Case "العقارات" .ColorIndex = 3 Case "الصيانة" .ColorIndex = 8 Case "المالية" .ColorIndex = 38 End Select End With 1: Application.EnableEvents = True End Sub

أولا : فضلا لا أمرا الرجاء تغيبر اسم ظهورك إلى اللغة العربية بدلا من الأنجليزية كما هو المعمول به في هذا المنتدى ثانيا : تفضل اضغط زر ترحيل وسيقوم بالمهمة جرب المرفق جدول تصفية المنح1.rar

السلام عليكم ورحمة الله وبركاته اخي ياسر خليل أبو البراء جزاك الله خيرا

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

أخي الكريم عبد العزيز بدلاً من الحلقات التكرارية والتي ستشكل عبء في أثناء التعامل مع الملف آثرت أن يكون التغيير في العمود الرابع بناءً على إخداث تغيير في أي خلية من خلايا العمود الثالث جرب الكود التالي عله يفي بالغرض Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim I As Integer If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 3 Then Application.ScreenUpdating = False Application.EnableEvents = False With Target.Offset(, 1) .ClearFormats If Target.Value = "المقاولات" Then With .Font .Bold = True: .Italic = True: .ColorIndex = 5 End With ElseIf Target.Value = "العقارات" Then With .Font .Bold = True: .Italic = True: .ColorIndex = 3 End With ElseIf Target.Value = "الصيانة" Then With .Font .Bold = True: .Italic = True: .ColorIndex = 8 End With End If End With Application.ScreenUpdating = False Application.EnableEvents = True End If End Sub تقبل تحياتي

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة كيفية عمل مؤقت (chronometre) في الاكسل تم ارفاق كود الحل من الفاضل / الحسامي رحمه الله _ الاستاذ / محمد يحياوي و لا تنسونا من صالح الدعاء ساعة (HOSSMI).rar مؤقت (HOSSMI).rar xntimer (يحياوى).rar كرونو (يحياوى).rar

تسلم الايادي الف الف شكر

أخي الحبيب الجموعي ممكن ترفق آخر ملف يحدث فيه الخطأ للإطلاع على الملف ومحاولة فهم المشكلة بشكل أدق عموماً لحين إرفاق ملف جرب السطر بالشكل التالي LI = ListBox1.Column(ListBox1.Index) تقبل تحياتي

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

غير سطر الحلقة التكرارية إلى السطر التالي لتحدد الأوراق المطلوبة For Each Ws In Worksheets(Array("Washing", "Accident"))

وهل اصبح الموضوع واضح الان ، ام تحتاج لمزيد من التوضيح ؟ جعفر

خلاص مشي الحال عملت الكويري هو النموذج الفرعي واضفت اسم الاب والجد والحمد لله

السلام عليكم أخي صالح لم ارد الرد ، ولكن بما انك ارسلت لي رسالة على الخاص ، فهذا دلوي : الاستعلام الذي عملته انت ، يأخذ معياره من قيمة موجودة (مثله مثل لو طلعت لك رسالة تطالب بالقيمة ، وانت ادخلت القيمة ، فلن تظهر لك الرسالة) ، ولكن ، غير المعيار (مثلا) : من [جدول2]![id] الى [جدول2]![id2] واضغط على زر الامر في النموذج ، فاذا ادخلت رقم صح ، مثلا 1 ، فلن تظهر لك الرسالة (كما هو الحاصل مع الاخ الشاعر) ، ولكن عندما تنقر على الزر cancel ، فستظهر لك رسالة الخطأ (كما هو الحاصل مع الاخ الشاعر) ، وهنا بيت القصيد جعفر

بارك الله فيكم

اخى الكريمعامر ياسر واثراءاً للموضوع جرب الملف التالى لعلك تجد فيه غايتك abo_abary_اضافة ارقام بشرط.rar

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

السلام عليكم أخوتي الكرام تفضلوا الحل بسحر جزائري. ههه قيمة محسوبة.rar

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

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

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

السلام عليكم ورحمة الله وبركاته : جرب هذا المرفق لعله المطلوب اضافة ارقام بشرط.rar

مرحبا استاذ صالح مشاركة مع اخوتي جرب لكي تعرف اول سجل في الجدول وكما هو بدون تاثيرات الفرز و بعد الاستيراد استخدم =DLookUp("[nom]","tbl") ولكي تعرف اول سجل بعد الفرز (الترتيب) اعمل استعلام مطبقا به الترتيب حسب الاختيار ثم احفظه وليكن باسم query1 واستخدم =DLookUp("[nom]","Queryl") هذا والله اعلم

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

كيف تبحث عن كل الخلايا التي تحتوي على شيء معين و تستبدلها بشيء اخر موضوع ليس بالجديد لكن يمكن تنفيذه بطريقة غير الكلاسيكية (أقصد غير Find and Replace العادية) Find & replace.rar

جزاك الله خيراً أخي الحبيب سليم ولا حرمنا الله منك ولا من جديدك الممتع والرائع تقبل تحياتي

جرب هذا التعديل abo_abary_ConditionalFomat.rar

جرب هذا الشي تعدد شراء سعر نفس الصنف salim.rar

أخي الكريم جمال محمود في ورقة العمل المسماة "All" قم بحذف الصفوف كلها بداية من الصف السادس إلى آخر صف .. وحول الجدول إلى نطاق عادي ثم ضع الكود التالي في موديول عادي ثم نفذ الأمر .. Sub YasserKhalil() Dim Ws As Worksheet, Sh As Worksheet Dim LR As Long, Last As Long Set Sh = Sheets("All") Application.ScreenUpdating = False Application.DisplayAlerts = False With Sh .Range("A6:G10000").Clear 'حلقة تكرارية لكل أوراق العمل لجلب البيانات من الأعمدة المحددة For Each Ws In ThisWorkbook.Worksheets If Ws.Name <> "All" Then LR = Ws.Cells(Rows.Count, 1).End(xlUp).Row Last = .Cells(Rows.Count, "B").End(xlUp).Row Ws.Range("E2:I" & LR).Copy .Range("B" & Last + 1).PasteSpecial xlPasteValues End If Next Ws Last = .Cells(Rows.Count, "B").End(xlUp).Row + 1 'وضع عبارة "تم التقدير" في العمود السابع .Range("G6:G" & Last).Value = "تم التقدير" 'ترقيم العمود الأول With .Range("A6:A" & Last + 1) .Formula = "=IF(B6="""","""",ROW()-5)" .Value = .Value End With 'دمج خلايا المجموع ووضع المعادلة في الخلايا المدمجة With .Range("A" & Last & ":B" & Last) .Merge .Value = "المجموع" End With With .Range("C" & Last & ":G" & Last) .Merge .Formula = "=SUM(F6:F" & Last - 1 & ")" End With 'تسطير جدول البيانات التي تم جلبها .Range("A5").CurrentRegion.Borders.Value = 1 'تنسيق نطاق البيانات With .Range("A5").CurrentRegion.Offset(1) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Bold = True End With End With Application.CutCopyMode = False Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub في الكود يوجد بعض التعليقات التي تساعدك في فهم الكود تقبل تحياتي

تم العمل حسب المطلوب فقط اضغط (اعجاب) copy_rng.rar

الصنف الكمية سعر الشراء القيمة الموردين صنف 1 10 15 150 مورد1 صنف 1 5 16 80 مورد2 صنف 1 5 18 90 مورد3 إجمالي كمية الصنف1 = 10 + 5 + 5 = 20 تكلفة إجمال الشراء = 150 + 80 + 90 = 320 التكلفة الفعلية للصنف = 320 /20 = 16 إذا تكلفة الصنف هي 16 ويقال لها متوسط السعر إلا إذا تقصد ان تتم عليها حركة بيع وشراء فلها إحتساب آخر محاسبيا.

اخى الكريم جلال محمد السلام عليكم قم بتغيير اسم العمود الى اخر عمود تريد توزيع الفرز عليه Range("a2:b" & LR).Select

السلام عليكم ورحمة الله وبركاته أحبائى فى الله أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت Sub PasswordBreaker() 'Breaks worksheet password protection. Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub

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

أخى الحبيب قنديل بعد التحية تفضل ما تريد ابجده فور الكتابه.rar

السلام عليكم اخي الكريم هنا محاولة اتمنى ان تكون المطلوب حسب فهمي للموضوع R01_InvoiceDetails1.rar

السلام عليكم اخي الكريم مرفق ملفين قد تستفيد منهم ساعة.rar مؤقت.rar