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

تفضل استاذ @ابو عبد الله العراقي محاولتي حسب مافهمت . اليك الكود بعد التعديل . MergMic_KH_3.rar

Try #If VBA7 Then Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr #Else Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long #End If Function CreateElevatedFile(ByVal sFilePath As String, ByVal sFileContent As String) As Boolean On Error GoTo ErrorHandler Dim fso As Object, sScriptPath As String, psScript As String, EscFilePath As String, EscContent As String sScriptPath = Environ("TEMP") & "\create_elevated_file.ps1" EscFilePath = Replace(Replace(sFilePath, "'", "''"), """", "\""") EscContent = Replace(Replace(sFileContent, "'", "''"), """", "\""") psScript = "$t = [System.Diagnostics.ProcessWindowStyle]::Hidden;$p = Start-Process -WindowStyle $t -FilePath 'powershell.exe' -ArgumentList '-Command ""Set-Content -Path \""" & EscFilePath & "\""` -Value \""" & EscContent & "\""""' -Verb RunAs -PassThru;$p.WaitForExit();Exit $p.ExitCode" Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(sScriptPath, True) .WriteLine psScript .Close End With ShellExecute 0, "runas", "powershell.exe", "-ExecutionPolicy Bypass -WindowStyle Hidden -File """ & sScriptPath & """", vbNullString, 0 CreateElevatedFile = True Exit Function ErrorHandler: CreateElevatedFile = False End Function Sub Create_File_With_Elevated_Permissions() Dim success As Boolean success = CreateElevatedFile("C:\Windows\Test.txt", "This Was Created With Elevated Permissions") If success Then MsgBox "File Created Successfully", vbInformation Else MsgBox "File Not Created", vbExclamation End If End Sub

الحمد لله إنها أمورك كما تريد 😇 قمت بتعديل الإستعلام الأخير ليسهل قراءته بما إنك تعمل على حقول وجداول قد تختلف عن المرفق قليلاً. .

اشكر مرورك الكريم اخى الفاضل

نعم أخي الكريم .. قد أدى المطلوب بحمد الله ، فجزاك الله خيرا وأحسن إليك وقد قمت بتجربته على الملف الأصلي والنتائج صحيحة بحمد الله، وقمت باختصار بعض الجمل في الاستعلام بناء على معرفتي بالحقول ومدلولاتها فأصبح هكذا: SELECT TAB.MNO, TAB.TNO, TAB.NASS, TAB.NASS1, TAB.TYPE1, TAB.TYPE2, Tab_Msaneed.MSNO, Tab_Msaneed.MS_NAMEX, TAB_Subject.SName, TAB_Subject.LVLno, TAB_Subject.Code, TAB_Subject.Total, TAB_Subject.LVL1, TAB_Subject.LVL2, TAB_Subject.LVL3, TAB_Subject.LVL4, TAB_Subject_X.MAIN_sub, TAB_Subject.ID, TAB_Subject.Xsub, TAB_Subject.ID_Xsub, (SELECT SName FROM TAB_Subject AS L1 WHERE L1.LVL1 = TAB_Subject.LVL1 AND L1.LVL2 = 0) AS LVL1name, (SELECT SName FROM TAB_Subject AS L2 WHERE L2.LVL2 = TAB_Subject.LVL2 AND L2.LVL3 = 0) AS LVL2name, (SELECT SName FROM TAB_Subject AS L3 WHERE L3.LVL3 = TAB_Subject.LVL3 AND L3.LVL4 = 0 AND L3.LVL3 > 0) AS LVL3Name, (SELECT SName FROM TAB_Subject AS L4 WHERE L4.LVL4 = TAB_Subject.LVL4 AND L4.LVL4 > 0) AS LVL4Name, (SELECT LISTname FROM DATA_list WHERE NOM2 = TAB.TYPE1 AND NOM1 = 1) AS TYPE1name, (SELECT LISTname FROM DATA_list WHERE NOM2 = TAB.TYPE2 AND NOM1 = 2) AS TYPE2name FROM (Tab_Msaneed INNER JOIN TAB ON Tab_Msaneed.MSNO = TAB.MUSNAD) INNER JOIN (TAB_Subject INNER JOIN TAB_Subject_X ON TAB_Subject.ID = TAB_Subject_X.SUB_ID) ON TAB.MNO = TAB_Subject_X.MNO ORDER BY TAB.TNO;

طيب .. بطريقتي سأسأل .. هل الفرق هو الحقول التالية :- TNO, NASS, nass1 MSNO, MS_NAMEX من جدول Tab_Msaneed ID_Xsub, Code, Parentx, Total, LVLno, Xsub MAIN_sub من جدول TAB_Subject_X يعني مقصدي انت تريد اضافة كافة الحقول الى الاستعلام الذي خرجت به ويلبي حاجتك في القيم المطلوب عرضها ، صحيح ؟؟؟ مع العلم أنك تستطيع إزالة الشرط :- AND TAB_Subject.ID IN (76, 159, 1873) هل هذا الاستعلام يلبي احتياجك على سبيل المثال :- SELECT TAB.MNO, TAB.TNO, TAB.NASS, TAB.nass1, Tab_Msaneed.MSNO, Tab_Msaneed.MS_NAMEX, TAB_Subject.ID, TAB_Subject.ID_Xsub, TAB_Subject.SName, TAB_Subject.Code, TAB_Subject.Parentx, TAB_Subject.Total, TAB_Subject.LVLno, TAB_Subject.LVL1, IIf(TAB_Subject.LVL1 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L1 WHERE L1.LVL1 = TAB_Subject.LVL1 AND L1.LVL2 = 0 AND L1.LVL3 = 0 AND L1.LVL4 = 0)) AS LVL1name, TAB_Subject.LVL2, IIf(TAB_Subject.LVL2 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L2 WHERE L2.LVL1 = TAB_Subject.LVL1 AND L2.LVL2 = TAB_Subject.LVL2 AND L2.LVL3 = 0 AND L2.LVL4 = 0)) AS LVL2name, TAB_Subject.LVL3, IIf(TAB_Subject.LVL3 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L3 WHERE L3.LVL1 = TAB_Subject.LVL1 AND L3.LVL2 = TAB_Subject.LVL2 AND L3.LVL3 = TAB_Subject.LVL3 AND L3.LVL4 = 0)) AS LVL3name, TAB_Subject.LVL4, IIf(TAB_Subject.LVL4 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L4 WHERE L4.LVL1 = TAB_Subject.LVL1 AND L4.LVL2 = TAB_Subject.LVL2 AND L4.LVL3 = TAB_Subject.LVL3 AND L4.LVL4 = TAB_Subject.LVL4)) AS LVL4name, TAB_Subject.Xsub, TAB_Subject_X.MAIN_sub, TAB.TYPE1, (SELECT LISTname FROM DATA_list WHERE NOM2 = TAB.TYPE1 AND NOM1 = 1) AS TYPE1name, TAB.TYPE2, (SELECT LISTname FROM DATA_list WHERE NOM2 = TAB.TYPE2 AND NOM1 = 2) AS TYPE2name FROM ((TAB INNER JOIN Tab_Msaneed ON TAB.MUSNAD = Tab_Msaneed.MSNO) INNER JOIN TAB_Subject_X ON TAB.MNO = TAB_Subject_X.MNO) INNER JOIN TAB_Subject ON TAB_Subject_X.SUB_ID = TAB_Subject.ID ORDER BY TAB.TNO;

جرب هذا التعديل .. BASE_e.accdb

هذا أحد احتمالات لم تكن في حسبانك ، ورقمها 1 - 4 ، وعليه سيتم اضافة جملة Case لهذا الشكل الجديد من الإحتمالات .. Case (zawjValue = 1 And zawjaValue = 4) يوجد مربع نص = Txx في التقرير ، غير مهم ، وتستطيع حذف اي شيء متعلق به في الكود ، فهو كان فقط لتحديد الإحتمالات التي كنت أعمل عليها . فتح تقرير FACE16.zip

امممم تقريباً بدأ افهم 😅😅 جرب هذا الاستعلام !!! SELECT TAB_Subject.ID, TAB_Subject.LVL1, IIf(TAB_Subject.LVL1 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L1 WHERE L1.LVL1 = TAB_Subject.LVL1 AND L1.LVL2 = 0 AND L1.LVL3 = 0 AND L1.LVL4 = 0)) AS LVL1name, TAB_Subject.LVL2, IIf(TAB_Subject.LVL2 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L2 WHERE L2.LVL1 = TAB_Subject.LVL1 AND L2.LVL2 = TAB_Subject.LVL2 AND L2.LVL3 = 0 AND L2.LVL4 = 0)) AS LVL2name, TAB_Subject.LVL3, IIf(TAB_Subject.LVL3 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L3 WHERE L3.LVL1 = TAB_Subject.LVL1 AND L3.LVL2 = TAB_Subject.LVL2 AND L3.LVL3 = TAB_Subject.LVL3 AND L3.LVL4 = 0)) AS LVL3name, TAB_Subject.LVL4, IIf(TAB_Subject.LVL4 = 0, Null, (SELECT TOP 1 SName FROM TAB_Subject AS L4 WHERE L4.LVL1 = TAB_Subject.LVL1 AND L4.LVL2 = TAB_Subject.LVL2 AND L4.LVL3 = TAB_Subject.LVL3 AND L4.LVL4 = TAB_Subject.LVL4)) AS LVL4name, TAB.TYPE1, (SELECT LISTname FROM DATA_list WHERE NOM2 = TAB.TYPE1 AND NOM1 = 1) AS TYPE1name, TAB.TYPE2, (SELECT LISTname FROM DATA_list WHERE NOM2 = TAB.TYPE2 AND NOM1 = 2) AS TYPE2name FROM TAB, TAB_Subject_X, TAB_Subject WHERE TAB.MNO = TAB_Subject_X.MNO AND TAB_Subject_X.SUB_ID = TAB_Subject.ID AND TAB_Subject.ID IN (76, 159, 1873) ORDER BY TAB_Subject.ID; استخدمت الدالة IIf في كل حقل من حقول أسماء المستويات ، ونجعل الاسم يظهر فقط إذا كانت القيمة المقابلة > 0 ، وإلا = Null هل التالي صحيح في الصورة ؟

السلام عليكم ورحمة الله وبركاته kkhalifa1960 عاشت ايدك استاذ ممنون منك في ميزان حسانتك ان شاء الله

Select column A for example then from Data tab select Data Validation Select Custom and paste the formula This is the formula you can use =AND(ISNUMBER(VALUE(MID(A1,5,3))), ISNUMBER(VALUE(MID(A1,9,4))), ISERROR(VALUE(LEFT(A1,3))), MID(A1,4,1)="-", MID(A1,8,1)="-", LEN(A1)=12)

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

إثراءا للموضوع يمكنك توسيع منع التكرار على عدة أعمدة مثلا A - C - E Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, OnRng As Range, Cell As Range Dim ColArr As Variant, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False ColArr = Array("A", "C", "E") ' ColArr = Array("A") For i = LBound(ColArr) To UBound(ColArr) If Not Intersect(Target, Me.Range(ColArr(i) & "2:" & ColArr(i) & Me.Rows.Count)) Is Nothing Then Set OnRng = Me.Columns(ColArr(i)) For Each Cell In Intersect(Target, OnRng) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(OnRng, Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If Next i CleanExit: Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب الملف يتم الحدف عند الادخال او عند اللصق Private Sub Worksheet_Change(ByVal Target As Range) Dim rngChanged As Range Dim cell As Range Dim dict As Object Dim lastRow As Long Dim ws As Worksheet Set ws = Me lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rngChanged = Intersect(Target, ws.Range("A1:A" & lastRow)) If rngChanged Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In ws.Range("A1:A" & lastRow) If Not Intersect(cell, rngChanged) Is Nothing Then GoTo NextCell If Not IsEmpty(cell.Value) Then dict.Add CStr(cell.Value), 1 End If NextCell: Next cell For Each cell In rngChanged If Not IsEmpty(cell.Value) Then If dict.exists(CStr(cell.Value)) Then Application.Undo ' MsgBox "القيمة '" & cell.Value & "' موجودة مسبقاً!", vbExclamation, "تنبيه" Exit For Else dict.Add CStr(cell.Value), 1 End If End If Next cell Application.EnableEvents = True Application.ScreenUpdating = True End Sub no duplicate.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته هل ترغب بإستخدام الأكواد ؟ ادا كان هدا يناسبك ضع هدا في حدث الورقة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Cell As Range, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False If Not Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) Is Nothing Then For Each Cell In Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(Me.Range("A:A"), Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If CleanExit: Application.EnableEvents = True End Sub

اخي واستاذي @Foksh اولا لكم مني جزيل الشكر على مرورك الكريم وسرعة الاستجابه هذا بالفعل هوا المطلوب

تفضل استاذ @RAIANESAMI مرفق حسب مافهمت . ووافني بالرد . PDF Report.rar

استاذ @محمد119900 أما اذا احتجت طلبك بشغل أكسس يوجد زر جديد بالفورم (MultiColumnTable) اسمه (CreateMultiColumnTable) بيسوي طلبط كما فهمت . تفضل التعديل . باركود نهائي مرتب المواد والشعب والطلاب (3).rar

وعليكم السلام ورحمة الله وبركاته ،، أخي الكريم يوجد أكثر من طريقة واسلوب وحل ، ولكن قبل الشروع بذكر أحدها سأنصحك نصيحة متفرعة = 1. الإبتعاد عن التسميات العربية للجداول والحقول والنماذج ومكوناتها . 2. عدم استخدام "-" في التسميات ، والأفضل استخدام "_" إن كنت مضطراً . الآن في النموذج سنقوم بحذف جميع الأكواد ولا حاجة لها ولا حاجة للزر أيضاً ، ثم في مديول جديد ألصق الكود التالي :- Public Sub UpdateEmployeeFiles() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPath As String Dim strFileName As String strPath = CurrentProject.Path & "\" Set db = CurrentDb Set rs = db.OpenRecordset("جدول1", dbOpenDynaset) If Not rs.EOF Then rs.MoveFirst Do Until rs.EOF strFileName = strPath & rs!رقم_الموضف & ".pdf" rs.Edit If Dir(strFileName) <> "" Then rs!لديه_ملف = "نعم" rs!مسار_الملف = strFileName Else rs!لديه_ملف = "لا" rs!مسار_الملف = Null End If rs.Update rs.MoveNext Loop End If rs.Close Set rs = Nothing Set db = Nothing End Sub وفي النموذج يكفينا الإستدعاء للدالة في حدث عند التحميل كما يلي :- Private Sub Form_Load() UpdateEmployeeFiles End Sub حيث أن الدالة ستقوم بتحديث قيمة الحقل في كل مرة تفتح فيها النموذج للموظفين الذين لديهم ملف PDF أو لا . أيضاً سيتم تعديل مسار الملف اذا كان موجوداً بدلاً من استخدامك للكود السابق في حدث "في الحالي" . FILE.zip

الفصل الثالث CH3.docx

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

السلام عليكم ورحمة الله وبركاته بعد اذن معلمنا واستاذنا محمد هشام جدول2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Const ShName As String = "جدول عام" Sub Coloring_Classes() On Error GoTo EndClear SetApp False Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) Dim i As Long, r As Long, c As Long, ColAL As Long, ColA As Long Dim tmps As Object: Set tmps = CreateObject("Scripting.Dictionary") Sh.Range("B6:AJ23").Interior.ColorIndex = xlNone ColAL = Sh.Cells(Sh.Rows.Count, "AL").End(xlUp).Row ColA = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row For i = 5 To ColAL If Len(Sh.Cells(i, "AL").Value) > 0 Then If Sh.Cells(i, "AM").Interior.ColorIndex <> xlColorIndexNone Then tmps(Sh.Cells(i, "AL").Value) = Sh.Cells(i, "AM").Interior.Color End If End If Next i For r = 5 To ColA If tmps.exists(Sh.Cells(r, "A").Value) Then For c = 2 To 36 With Sh.Cells(r, c) If Len(.Value) > 0 Then .Interior.Color = tmps(Sh.Cells(r, "A").Value) End With Next c End If Next r EndClear: SetApp True End Sub '""""""""""""""""""""""""""""""""""""""" Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable .EnableEvents = enable .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub جدول.xlsm

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

تفضل كود إخفاء (2).xlsm

وعليكم السلام ورحمة الله وبركاته الطريفة الاولى قبل حفظ الملف ارجع الى الصفحة الرئيسية ثم حفظ الطريقة الثاتية عن طريق كود وسيقوم بفتح الصفحة الرئيسية حتى لو قمت بالحفظ عند ورقة 10 مثلا ضع هذا الكود في محرر الاكود في ThisWorkbook Private Sub Workbook_Open() Sheets("SHEET1").Activate End Sub طبعا غير اسم SHEET1 بالكود باسم الشيت الرئيسى لديك

هو الحل مثل ما قال شيخنا ابو خليل ربي يمتعه بالصحة عند تصغير مربع نص اي جهاز لايقرا الباركود فالحل بالنسبة لي ليس الاضافة من نوع ( barcodex.ocx ) كما قال عليها الاستاد جعفر ان الشركة ستلغي استخدام هدا النوع من الملفات لاسباب امنية الله اعلم الموضوع عند الاستاد جعفر فانا لم اتعمق فيه ما تعلمته من بحر البرمجة (ادا اردت النجاح - فاشتري ما تريد العمل به ) فهدا ما سافعل ابتداء من البرامج التي استخدمها الى الخط التجاري مثل باركود كي لا تواجهني اي انتقادات من المشتري وهدا مثال بسيط , طباعة ورقة (A4 ) وطبــاعة ملصقــات ( Role ) على الباركود الدي استخدمه فهو فعال مع جميع الاجهزة عبار عن موديول لخط ( Code128 ) اي استفسار او ملاحظة انا موجود بادن الله كما انوه للاخوة الدين يشتغلون في هدا المجال - الامور قد تطورت لابعد حدود مع الدكاء الاصطناعي فما كان المبرمج يبحث عن مساعدة او تطوير يستغرق من وقته عدة اسابيع او لنقول مدة طويل اليوم مع الدكاء الاصطناعي , مشروع لا ياخد منك اكثر من اسبوع بتصحيح اخطاء التي نقع فيها ادا كان البرنامج كبير فما عليكم الى بهاد الموقع وهو مجاني https://chatgpt.com/ ويوجد مواقع اخرى في عدة مجالات مجانية ومدفوعة فسؤالك بنسبة للبرمجة بجميع انواعها ستجد امثلة P_barcode.accdb

السلام عليكم ثلاثة برامج لمن يبحث عن برامج جمعبات خيرية والبرامج الثلاثة مع بعض قابلين لتعديل مكتب هيئة الإغاثة .zip رقم سري :1 ContributorData.rar رقم سري :1234 جمعية الوفاء.rar

وعليكم السلام ورحمة الله وبركاته أستاذي الكريم الغالي : أجزل الله لكم المثوبة على ما تفضلتم به . وهنا أمثلة أخرى لإتمام الفائدة [لعل برنامج الخيرية أشملها] http://www.4shared.com/zip/fUoaAaH4/_online.html وهنا برنامج الخيرية لوحده http://www.mediafire.com/download/xx3lds7t4ca94jm/kyryh.zip

استاذ قبل مانغلق الموضوع تلقيت صباح اليوم مشكلة عندما طلب مني الزوج شهادة عدم اعادة الزواج بحكم ان زوجته متوفية ولم يتزوج بعدها فظهر التقرير كله خطوط علما ان مربع النص Za6 وتاريخ الوفاة Da6 يخص الزوجة فكيف يتم اذا اخترت الزوجة تظهر اسمها واذا اخترت الزوج يظهر اسمه التعديل يكون في التقرير Face8