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

يمكنك ذلك من خلال هذه المعادلة -وهذه معادلة مصفوفة (Ctrl+Shift+Enter) ويمكنك استخدامها مرة بالدولار ومرة أخرى بالريال .. وتم وضع المعادلة بالخلية D2 =SUMPRODUCT((الجدول1[عملة العرض]=$E$1)*(SUBTOTAL(109,OFFSET(I3,ROW(الجدول1[[المبلغ ]])-ROW(I3),0)))) معادلة Subtotal للخلايا المرئية فقط وبشرط.xlsx

وعليكم السلام -نعم يمكن ذلك بهذا الكود Sub Splitbook() Dim xPath As String xPath = Application.ActiveWorkbook.Path Application.ScreenUpdating = False Application.DisplayAlerts = False For Each xWs In ThisWorkbook.Sheets xWs.Copy Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx" Application.ActiveWorkbook.Close False Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub أو كان عليك من البداية استخدام خاصية البحث بالمنتدى قبل طرح مشاركتك فبها طلبك كيفية فصل الشيتات الموجودة داخل الملف إلى ملفات منفصلة الملف به اربع صفحات.xlsm

السلام عليكم أخي الكريم يرجى تجربة الملف المرفق مع رجاء الإبقاء على الخليتين A5 :A6 دون تغيير أو مسح لأنها تحتوي على الـ Criteria وقد تم إخفاؤها من حيث جعل لون الكتابة مثل لون خلفية الخلية قمت بنقل تصفية البيانات إلى sheet2 حيث كلما تقوم بالتغيير في sheet1 يتم التغيير بشكل تلقائي في sheet2 تقبل تحياتي Salary_Printing.xlsm

وعليكم السلام-تفضل تم عمل قائمة منسدلة بأرقام الجلوس وبناءاً على اختيارك منها سيتم جلب بيانات الشهادات شهادات ,والراسبين 4 تعريق 1متغيرات.xlsm

أستاذنا @ابو جودي .. سبب هذي الرسالة هو الحقل C في الجدول tbldata : وهو من نوع Large Number .... حاول ألا تستخدم هذا النوع من البيانات إطلاقا في برامجك لأنها ميزة مضافة في النسخ الحديثة 2016 وفوق .. لذلك إذا استخدمته لن يعمل البرنامج معاك في النسخ الأفدم .. وعوضا عن ذلك استخدم نوع البيانات Number فقط ومن خصائص الحقل في الأسفل ضع الفيلد سايز = Long Integer عن تجربة 😉👌🏼

جزاكم الله خيرا اخي الكريم صحيح أنك استخدمت دالة Filter وقد أدت الغرض المطلوب بشكل رائع يغني عن الموديول، لكن للأسف ليست موجودة في نسخة 2016 التي أستخدمها في العمل. ولذلك فإنني استخدمت الإمكانيات المتاحة لي فاعذرني. تقبل تحياتي العطرة لشخصكم الكريم والسلام عليكم ورحمة الله وبركاته 💐🏵️

اخي ..شاهد المرفق ما الخطأ في الكود.xlsm

تفضل اضف هذا الكود في جميع الصفحات في حدث عند الفتح Dim ctl As Control For Each ctl In Me.Controls If TypeName(ctl) = "Label" Then Form.Controls(ctl.Name).Caption = Replace(Translate(Form.Controls(ctl.Name).Caption, "auto", "ar"), ":", "") Form.Controls(ctl.Name).FontName = "Times New Roman" Form.Controls(ctl.Name).FontWeight = 900 End If If TypeName(ctl) = "CommandButton" Then Form.Controls(ctl.Name).Caption = Replace(Translate(Form.Controls(ctl.Name).Caption, "auto", "ar"), ":", "") Form.Controls(ctl.Name).FontName = "Times New Roman" Form.Controls(ctl.Name).FontWeight = 900 End If If TypeName(ctl) = "Page" Then Form.Controls(ctl.Name).Caption = Replace(Translate(Form.Controls(ctl.Name).Caption, "auto", "ar"), ":", "") End If Next ctl الترجمة بإستخدام Google Database12222.zip

هو حضرتك جايب الارقام دي من فين ؟ لان حسب مثالك دي النتائج للاسف انا ضعيف فى هذا الباب ممكن نسأل اهل العلم فى هذا الجانب مثل استاذى الكريم @ابو جودي @Moosak

وعليكم السلام ورحمة الله وبركاته مجهود جبار و عمل مميز بارك الله فيك وجزاك الله خيراً

السلام عليكم ورحمة الله تعالى وبركاته احيانا نريد التأكد من وجود قيمة محددة فى حقل محدد داخل جدول محدد وذلك حتى نتأكد من عدم حدوث تكرار وطبعا كالعادة سوف اقدم لكم اليوم فكرتى المتواضعة فى هذا الشأن من خلال استخدام وظيفة عامة تعمل كروتين من خلال وحدة نمطية بحيث يتم اسناد القيم التى تخص كل من القيمة واسم الحقل واسم الجدول الى متغيرات عامة ليتم الفحص يعنى مثل ما سوينا من قبل مع المعرف الخاص البرمجى هنا فى هذا الموضوع '|-----------------------------------------------------------| '|---15/09/1443-------16/04/2022_____________________________| '|___www.officena.net________________________________________| '| | '| _ +-----------officena-----------+ _ | '| /o) | ||||| | (o\ | '| / / | @(~O^O~)@ | \ \ | '| ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| (\\\ \_/ / \ \_/ ///) | '| \ / \ / | '| \____/________Mohammed Essam________\____/ | '| 15/09/1443 | '| 16/04/2022 | '| | '|_____www.officena.net______________________________________| '|_____Thank you for visiting https://www.officena.net_______| '|-----------------------------------------------------------| '======Check Input Exist By Input Type======================================================================================================================================' ' ____ __ ____ ____ __ ____ ____ __ ____ ______ _______ _______ __ ______ _______ .__ __. ___ .__ __. _______ .___________. ' ' \ \ / \ / / \ \ / \ / / \ \ / \ / / / __ \ | ____|| ____|| | / || ____|| \ | | / \ | \ | | | ____|| | ' ' \ \/ \/ / \ \/ \/ / \ \/ \/ / | | | | | |__ | |__ | | | ,----'| |__ | \| | / ^ \ | \| | | |__ `---| |----` ' ' \ / \ / \ / | | | | | __| | __| | | | | | __| | . ` | / /_\ \ | . ` | | __| | | ' ' \ /\ / \ /\ / \ /\ / __| `--' | | | | | | | | `----.| |____ | |\ | / _____ \ __| |\ | | |____ | | ' ' \__/ \__/ \__/ \__/ \__/ \__/ (__)\______/ |__| |__| |__| \______||_______||__| \__| /__/ \__\ (__)__| \__| |_______| |__| ' ' ' '===========================================================================================================================================================================' Public Function CheckInputExist( _ ByRef strFieldName As String, _ ByRef strTableName As String, _ ByVal strObjectContainFieldValue) As Boolean On Error GoTo ErrorHandler Dim strFormName As Access.Form Dim stLinkCriteria As String Dim strMsgTitel As String Dim strMsgPrt1 As String Dim strMsgPrt2 As String Dim strErrMsgTitel As String Dim strErrMsg As String Set strFormName = Screen.ActiveForm strMsgPrt1 = ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1593") & ChrW("1579") & ChrW("1608") & ChrW("1585") & ChrW("32") & ChrW("1593") & ChrW("1604") & ChrW("1609") & ChrW("32") & ChrW("46") & ChrW("46") & ChrW("13") & ChrW("10") & ChrW("40") & ChrW("160") strMsgPrt2 = ChrW("32") & ChrW("41") & ChrW("13") & ChrW("10") & ChrW("1587") & ChrW("1608") & ChrW("1601") & ChrW("32") & ChrW("1610") & ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1606") & ChrW("1578") & ChrW("1602") & ChrW("1575") & ChrW("1604") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1609") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1587") & ChrW("1580") & ChrW("1604") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1606") If Len(strObjectContainFieldValue) = 0 Or IsNull(strObjectContainFieldValue) Then Exit Function Select Case FieldTypeName(strFieldName, strTableName) Case Is = "Text": stLinkCriteria = strFieldName & "= '" & strObjectContainFieldValue & "'" Case Is = "Date/Time": stLinkCriteria = strFieldName & "= #" & Format(strObjectContainFieldValue, "dd/mm/yyyy") & "#" Case Is = "Long Integer": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Integer": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Byte": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Single": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Double": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Decimal": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue End Select If DCount("*", strTableName, stLinkCriteria) > 0 Then MsgBox$ strMsgPrt1 & strObjectContainFieldValue & strMsgPrt2, vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, "" strFormName.Undo strFormName.Recordset.FindFirst stLinkCriteria Else End If procDone: Exit Function ErrorHandler: strErrMsgTitel = ChrW("1582") & ChrW("1591") & ChrW("1571") & ChrW("32") & ChrW("1601") & ChrW("1609") & ChrW("32") & ChrW("1606") & ChrW("1608") & ChrW("1593") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1576") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") strErrMsg = ChrW("1604") & ChrW("1602") & ChrW("1583") & ChrW("32") & ChrW("1581") & ChrW("1575") & ChrW("1608") & ChrW("1604") & ChrW("1578") & ChrW("32") & ChrW("1573") & _ ChrW("1583") & ChrW("1582") & ChrW("1575") & ChrW("1604") & ChrW("32") & ChrW("1606") & ChrW("1608") & ChrW("1593") & ChrW("32") & ChrW("1576") & ChrW("1610") & _ ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") & ChrW("32") & ChrW("1594") & ChrW("1610") & ChrW("1585") & ChrW("32") & ChrW("1589") & ChrW("1581") & _ ChrW("1610") & ChrW("1581") & ChrW("46") & ChrW("46") & ChrW("46") & ChrW("13") & ChrW("10") & ChrW("32") & ChrW("1606") & ChrW("1608") & ChrW("1593") & _ ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") & ChrW("32") & ChrW("1575") & _ ChrW("1604") & ChrW("1605") & ChrW("1587") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1605") & ChrW("32") & ChrW("1607") & ChrW("1608") & ChrW("32") & _ ChrW("40") & ChrW("32") & FieldTypeName(strFieldName, strTableName) & ChrW("32") & ChrW("41") & ChrW("13") & ChrW("10") & ChrW("1605") & ChrW("1606") & ChrW("32") & _ ChrW("1601") & ChrW("1590") & ChrW("1604") & ChrW("1603") & ChrW("32") & ChrW("1602") & ChrW("1605") & ChrW("32") & ChrW("1576") & ChrW("1573") & ChrW("1583") & _ ChrW("1582") & ChrW("1575") & ChrW("1604") & ChrW("32") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") & ChrW("32") & _ ChrW("1578") & ChrW("1578") & ChrW("1591") & ChrW("1575") & ChrW("1576") & ChrW("1602") & ChrW("32") & ChrW("1605") & ChrW("1593") & ChrW("32") & ChrW("1606") & _ ChrW("1608") & ChrW("1593") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") _ & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1605") & ChrW("1587") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1605") Select Case Err.Number Case Is = 2471: MsgBox$ strErrMsg, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, strErrMsgTitel Case Is = 3075: MsgBox$ strErrMsg, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, strErrMsgTitel Case Else MsgBox$ Err.Number & ": " & Err.Description End Select Resume procDone End Function Public Function FieldTypeName(ByRef strFieldName As String, ByRef strTableName As String) As String Dim db As DAO.Database Dim objRecordset As DAO.Recordset Dim i As Integer Set objRecordset = CurrentDb.OpenRecordset(strTableName) For i = 0 To objRecordset.Fields.Count - 1 If strFieldName = objRecordset.Fields(i).Name Then Dim strReturn As String Select Case CLng(objRecordset.Fields.Item(i).Type) 'fld.Type is Integer, but constants are Long. Case dbBoolean: strReturn = "Yes/No" ' 1 Case dbByte: strReturn = "Byte" ' 2 Case dbInteger: strReturn = "Integer" ' 3 Case dbLong ' 4 If (objRecordset.Fields.Item(i).Attributes And dbAutoIncrField) = 0& Then strReturn = "Long Integer" Else strReturn = "AutoNumber" End If Case dbCurrency: strReturn = "Currency" ' 5 Case dbSingle: strReturn = "Single" ' 6 Case dbDouble: strReturn = "Double" ' 7 Case dbDate: strReturn = "Date/Time" ' 8 Case dbBinary: strReturn = "Binary" ' 9 (no interface) Case dbText '10 If (objRecordset.Fields.Item(i).Attributes And dbFixedField) = 0& Then strReturn = "Text" Else strReturn = "Text (fixed width)" '(no interface) End If Case dbLongBinary: strReturn = "OLE Object" '11 Case dbMemo '12 If (objRecordset.Fields.Item(i).Attributes And dbHyperlinkField) = 0& Then strReturn = "Memo" Else strReturn = "Hyperlink" End If Case dbGUID: strReturn = "GUID" '15 'Attached tables only: cannot create these in JET. Case dbBigInt: strReturn = "Big Integer" '16 Case dbVarBinary: strReturn = "VarBinary" '17 Case dbChar: strReturn = "Char" '18 Case dbNumeric: strReturn = "Numeric" '19 Case dbDecimal: strReturn = "Decimal" '20 Case dbFloat: strReturn = "Float" '21 Case dbTime: strReturn = "Time" '22 Case dbTimeStamp: strReturn = "Time Stamp" '23 'Constants for complex types don't work prior to Access 2007 and later. Case 101&: strReturn = "Attachment" 'dbAttachment Case 102&: strReturn = "Complex Byte" 'dbComplexByte Case 103&: strReturn = "Complex Integer" 'dbComplexInteger Case 104&: strReturn = "Complex Long" 'dbComplexLong Case 105&: strReturn = "Complex Single" 'dbComplexSingle Case 106&: strReturn = "Complex Double" 'dbComplexDouble Case 107&: strReturn = "Complex GUID" 'dbComplexGUID Case 108&: strReturn = "Complex Decimal" 'dbComplexDecimal Case 109&: strReturn = "Complex Text" 'dbComplexText Case Else: strReturn = "unknown" End Select End If Next i FieldTypeName = strReturn End Function يتم استدعاء الوظيقة بشكل عام من خلال الكود الاتى Call CheckInputExist("FieldName", "TableName", Me.txtBox) وأخيرا المرفق للتجربة ملاحظة : تم تعديل المرفق والكود بناء على رد استاذى الجليل الباش مهندس @Moosak التعديل النهائى بتحديث المرفق بتاريخ يوم السبت 22 رمضان 1443 هـ , 23 -أبريل -2022 م تم إضافة وظيقة للتعرف نوع البيانات المستخدم فى الحقل داخل الجدول Check Input Exist.accdb

وعليكم السلام ورحمة الله وبركاته مجهود جبار و عمل مميز بارك الله فيك وجزاك الله خيراً

اتفضل هذا التعديل Private Sub Commande24_Click() Dim varcode As String Dim vars As String Dim ContRec As Integer Dim DlookupRec As String DlookupRec = Nz(DLookup("mtRole", "listecont", "code='" & Forms!Chrche_Filter!code & "'"), 0) ContRec = DCount("code", "listecont", "[code]='" & Me.code & "'") Debug.Print "ContRec >> " & ContRec Debug.Print "DlookupRec >> " & DlookupRec If Me.code.Value <> "" Then varcode = "'" & Me.code.Value & "'" If x <> "" Then x = x & " and " End If x = x & "code = " & varcode & " " End If 'If Nz(DLookup("mtRole", "listecont", "code='" & Forms!Chrche_Filter!code & "'"), 0) <> 0 Then ' ' DoCmd.OpenReport "data", acViewPreview, , x 'Else ' DoCmd.OpenReport "nodata", acViewPreview, , x 'End If If (ContRec <> 0) And (DlookupRec = 0) Then DoCmd.OpenReport "nodata", acViewPreview, , x ElseIf (ContRec >= 1 And ContRec <= 3) And (DlookupRec <> 0) Then DoCmd.OpenReport "data_01_3", acViewPreview, , x ElseIf (ContRec >= 4 And ContRec <= 9999) And (DlookupRec <> 0) Then DoCmd.OpenReport "data_4_9999", acViewPreview, , x End If End Sub ايضا المرفق Database10_1.rar تم وضع معيارين معا واتمنى ان اكون قد وضحت الفكره لك وانك فهمت الكود كيف يعمل واذا كان هناك شئ غير مفهوم تفضل وسوف اشرحه لك او يشرحه لك اى شخص هنا

التعديل تم في حدث textBox14_Change textBox15_Change textBox16_Change

طبعاً هناك مشكلة .. ومشكلة كبيرة ,, هل تعتقد ان هناك من لديه الوقت الذى يسمح بعمل ملف لك بكل طلباتك على الجاهز , وان كان الأمر من وجهة نظرك بهذه البساطة ولا يحتاج الى ملف لكنت استطعت عمل المطلوب بنفسك ولا احتجت لرفعه هنا !!!!!... فكما تعلم يقيناً ان المنتدى تعليمى من المقام الأول وليس لتقديم البرامج الجاهزة ؟!!!

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

الحقيقة أخي أبو الحسن أنا كنت أحاول إيجاد حل لموضوعك بهذه الأداة حتى قبل ما أطرحها في المنتدى لكن واجهتني مشكلة أن دوال المجال لا تعمل مع الاستعلامات التي لها معايير مرتبطة بقيمة في نموذج (يطلب قيمة معلمة) وهذا بإقرار شركة مايكروسوفت .. والاستعلام (رصيد سابق) هو من هذا النوع ، حيث أنه يطلب بيانات من النموذج : لذلك لم تعمل الدوال معه .. فحاولت التوصل إلى مصدر البيانات الأصلي في الجداول ولكن لقلة فهمي للأمور المالية لم أتمكن من استيعاب فكرة الرصيد السابق من جذورها بعد عدة محاولات 😅 لذلك انسحبت بهدوء وتركت الميدان لأهله 😄🖐🏼️

ممكن تجرب هذا Private Sub Commande24_Click() Dim varcode As String Dim vars As String Dim ContRec As Integer ContRec = DCount("code", "listecont", "[code]='" & Me.code & "'") Debug.Print "ContRec >> " & ContRec If Me.code.Value <> "" Then varcode = "'" & Me.code.Value & "'" If x <> "" Then x = x & " and " End If x = x & "code = " & varcode & " " End If 'If Nz(DLookup("mtRole", "listecont", "code='" & Forms!Chrche_Filter!code & "'"), 0) <> 0 Then ' ' DoCmd.OpenReport "data", acViewPreview, , x 'Else ' DoCmd.OpenReport "nodata", acViewPreview, , x 'End If If ContRec <= 0 Then DoCmd.OpenReport "nodata", acViewPreview, , x ElseIf ContRec >= 1 And ContRec <= 17 Then DoCmd.OpenReport "data", acViewPreview, , x ElseIf ContRec >= 18 And ContRec <= 999999999 Then DoCmd.OpenReport "data", acViewPreview, , x End If End Sub طبعا لا تنسي ان تعدل فى اسماء التقارير حسب ما تريد

انت وضعت الكود داخل النموذج ليه تعديل قاعدتك Check Input Exist .accdb

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

تفضل هذا التعديل السهل و البسيط القي نظرة على الماكرو بعد التصدير ستجد ملف الاكسل بجوار برنامجك عملية الترحيل و الجلب من و الى اكسال.zip

تفضلي هذا التعديل لكن يجب تسجيل الفصول الدراسية اولاً و تم اعداد نموذج لذلك و بعد التسجيل بالإمكان اختيار الاسابيع الدراسية حسب الفصل الدراسي المحدد New Microsoft Office Access 2007 قاعدة بيانات (2)(1).mdb

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

احسن الله اليك اخى ومهندسنا العزيز @Eng.Qassim وجزاك الله كل خير على كل ما تقدمه لاخوانك وجعله الله فى ميزان حسناتك 🌹 واعلم بان بمقدورك ان تقدم افضل مما قدمت اخى واحببت ان اشاركك الاجر والثواب 💐 فلك من كل المحبه والتقدير والاحترام اخى

الحمدلله على سلامتك يا سيد المعلمين 😊✋🏻🌷 والغايب عذره معه 🌹 كتير أوي يا سيد المعلمين .. 😁🌹 يكفيني 513 إعجاب وشهادة كبيرة منك يا معلمنا 😇🌷 الحمدلله هذا كله من فضل الله وإنعامه .. ثم مما تعلمناه منكم ، وتشجيعكم الدائم 🙂 وأسأل الله تعالى أن يجيب دعواتك الصادقة يا حبيب الملايين 👐🏻 حاسس إني عارف اللي بتفكر بيه ( اللي بالي بالك ) 😉👌🏻 بس برضوه مش حقول ومستنيك وأفكارك ولمساتك المتميزة👍🏼😊

TEST03.xlsm

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

السلام عليكم تفضل أخي الكريم .. مع بعض التعديل test01.xlsm

تفضلي هذا التعديل New Microsoft Office Access 2007 قاعدة بيانات (2).accdb

وعليكم السلام-طبعاً لا يمكن عمل هذا بهذه المعادلات -فقط يمكنك استخدام هذه المعادلة =SUMIFS('All Details'!$C$6:$C$1000,'All Details'!$A$6:$A$1000,$E$5,'All Details'!$B$6:$B$1000,$C7) تقفيل نهائي-فاضي-Index-1Match.xlsx

نعم يعتبر مخالفه للتعدى على حقوق الاخرين ولكن قبل ان نقول مخالف فنساله هل هذا البرنامج ملكك وبتوضيح اكثر هل انت مصمم هذا البرنامج فان كان هو نتابع معه هل الامر متاح ام لا والسؤال الان للاخ السائل هل هى ملكك انت الذى صصمتها ؟ فان كان نعم يمكنك رفع البرنامج على اى موقع رفع خارجى مثل الميديا فير ووضع الرابط هنا وسوف ينظر اخوانك واساتذتنا جزاهم الله كل خير فى امكانيه الاستعاده من عدمه بالتوفيق

الماكرو المطلوب مبدئياً انقل الداتا الى صفجة مستقلة (انشاء صفحة جديدية) نفذ عليها ها الماكرو (يجب ان تيدأ البيانات من الخلية B4 قي المعادلة التي كتبتها انا يوجد * يجب وضعها حتى تعمل الدالة بشكل جيد لان الدالة (عند اسنعمال &) نتظر الى الرفمين 211 و 55 ( 55211) و تنطر الى الرقمين 11 و 552 (55211) اي نفس الشيء بنما عند استعمال النجمة يصبحون هكذا (211*55) و (11*552) مختلفين Option Explicit Sub Del_row() Dim i As Long Dim lr As Long: lr = Cells(Rows.Count, 2).End(3).Row On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Range("k4") = "salim" Range("k5:k" & lr).Formula = "=SUMPRODUCT(--(c5&d5&e5&f5&g5&h5=$c$5:c5&$d$5:d5&$e$5:e5&$f$5:f5&$g$5:g5&$h$5:h5))" Range("k5:k" & lr).Value = Range("k5:k" & lr).Value Range("M2").Formula = "=K5<>1" Range("k5:k" & lr).AdvancedFilter xlFilterInPlace, criteriarange:=Range("M1:M2") Range("k5:k" & lr).SpecialCells(12).EntireRow.Delete On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Range("k4:k" & lr).Clear: Range("m2").Clear End Sub

السلام عليكم ورحمة الله الكود السابق يقوم بالترحيل بدون تكرار الية الكود تعمل مثلا في الورقة (تم التنفيذ) اذا كان يوجد 4 صفوف مرحلة سابقا فالكود يقوم بالترحيل من الورقة (التسويق) بعد المرور على 4 صفوف باسم الورقة (تم التنفيذ) جرب المرفق بعد تعديل عمود الاحصاء في الكود الكود المرفق يقوم بالترحيل وحذف الصفوف المرحلة ارجو ان يكون المطلوب في امان الله ترحيل.rar

أخي العزيز / samycalls هذا التعديل في الكود ليفي بالغرض إن شاء الله Sub Macro3()[/b] [b]Application.Calculation = xlManual Application.ScreenUpdating = False Range("b2:b1000").ClearContents Sheets("ورقة1").Range("B1:B786").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("ورقة1").Range("B1:B786"), CopyToRange:=Range("E4"), _ Unique:=True Range("E4:E786").Sort Key1:=Range("E4"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range("E4").Select Application.ScreenUpdating = True Application.Calculation = xlAutomatic End Sub وهذا الملف بعد التعديل نقل بدون تكرار مع الترتيب3.rar