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

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

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

ضع المجلد في سي قد يروق لكم العمل Registeration book.zip

View File 🎁🔍📀💾Update_Sarach Nod Treeview 6 And All Show Nod And ListIMGe Change Icone All And Selected Nod Ms Access ( بحث فور للشجر وعرض كافة الجذور وتغير ايكون الشجرة مع تخصيص على اكسس )📡💿🔎 ☕🌹 برنامج للشجرة تحديث الجديد كانت للحسابات او تحاليل طبية او لاي نشاط + بحث الجذر وتخصيص محدث لاختيار Icon_For TreeView S6 للشجرة عند الضغط وتم الفتح + او اضافة للواجهة بقائمة رئيسية بالفهرسة تحدد الجذر بفتح النماذج والتقارير + -( TreeView S6 )- ====================(تحديث الجديد ) اختصار : 1-البحث من غير اغلاق النافذة وعرض المحدد من الجذر واختيار عرض كافة الجذور FixAT Add Tool TreeView.Claner !😇 كل بحث بحذر لحالة اذا بحثت يمسح ويضيف الجذر البحث ☕ 2-اختيار ايكون من ListImage مباشر Update(FixAt)☕ 3-Icon Open Nod OnClick And Change Icon ============================= يمكن تخصيص ListImage1 32 ListImage1 42 On TreeView Only One ... ====================(تحديث اقدم ) اختصار : 1-بحث من الشجرة وعرض كافة الجذور TreeView Only One ☕ 2-(FixAT)تصحيح اضافة قيد جديده مع ادخال بيانات اكثر مع التحديث والتحميل الاضافات 3- قائمة التحكم الكامل للشجرة من الالوان والخطوط اسم الخط وكامل تخصيص اعدادة الشجرة وتغير الانماط الشجرة Line 1-Tree_line 2-tree_Root_line Bord 1-ccNon 2-ccFixed Style 0-textOnly 1-Picture Text 2-PlusMines 3-Plus Picture Text 4-treelines text 5-treelines picture text 6-treelines PlusMines Text 7-treelines picture PlusMines Text 4-(FixAT)Show Root PlusMines with Update 5-Add_Menu Control TreeView Selected True Or False And Menu Save Startup Open App TreeView FullRowSelect Sorted HideSelection Enabled ChackBoxes SingleSel Scroll HotTracking ============== Indentation pathSeparator 6-(FixAT)Change Form Size And with Open Full Screen = (Mixmain) Show Video Down (تحكم بحجم النافذة وخصص زر لتتصحيح ثم تغير حجم نافذة البرنامج شاهد الفيديو في الاسفل) 7-Change Icon TreeView And Cange ImageList TreeView 6 Ezy =(Change Pakeg IMG Tree) 8-Change MousePointer on TreeView ========================= 0-ccDefault 1-ccArrow 2-ccCross 3-ccBeem 4-cclcon 5-ccSize 6-ccSizeNESW 7-ccSizeNS 8-ccSizeNWSE 9-ccSizeEW 10-ccUpArrow 11-ccHourglass 12-ccNoDrop 13-ccArrowHourglass 14-ccArrowQusition 15-ccSizeAll 99-ccCustom 💯 A Complit New Future Any Time OFF k☕ ===============( تشكيل الشجرة الى قائمة برنامج ) امكانية تعديل نمط الشجرة اختر 2 واختر من الخصائص Full_Line_Root وخصصة للبحث بتغير اسم الجذر Root تابع الفيديو في الاسفل الموضوع 🎥🎬❤️ =====================(البيانات للتجربة والحسابات نبذه منه ) =================================================================( تحديث القديم ) 1- بناء تلقائي مع تحديث تلقائي 2- تخصيص جذر للعرض القيود 3- تنوع تفقيط المبالغ لاي عملة فقط DlookUp On Function 4-واجهة ريبين Ribbon On Form 5-تغير نمط نص الجذر اذا كان ريسي او متفرع Control Nod And Selected Any item Change Style Text Nod on ActiveX TreeView S6 6-انشاء ملفات انت تحددها للكل جذر محدد على سبيل المثال عند فتح جذر قيود المحاسبية للاصول تجد انشاء ملف باسم الملفات للارفاق +مع قائمة اضافة اسماء الملفات وتحريرها Add_New_Folder_Nod For Save any File 7-تغير لون خلفية الشجرة مع الواجهة 8-قائمة الفهرسة للتعديل على : - مسميات الجذور انشاء جذور حذف الجذور -تحديث -ترمز لون المحدد للاضافة وتفريع 9-خيارات تخصيص الشجرة -فتح الجذور واغلاق الجذور 10-اضافة الجمع براس الجذر بعدد اجمالي الحقول ============================================== اتمنى ان ينال على اعجابكم Submitter hanan_ms Submitted 08/23/2024 Category قسم الأكسيس  

وعليكم السلام ورحمة الله وبركاته طبق التعليمات التالية وسوف يكون عندك بداية لقاعدة بيانات جيدة وعلى الطريق السليم: ========== لإنشاء قاعدة بيانات تلبي احتياجاتك، يجب تصميم الجداول والعلاقات بينها بشكل يساعدك على تخزين المعلومات المطلوبة بطريقة منظمة وفعّالة. بناءً على وصفك، تحتاج إلى ثلاثة جداول رئيسية: جدول الموظفين (Employees): يحتوي هذا الجدول على المعلومات الأساسية عن الموظفين مثل اسم الموظف، معلوماته الشخصية، وأحدث درجة وظيفية له. جدول الدرجات الوظيفية للموظفين (EmployeeGrades): يحتوي هذا الجدول على تاريخ منح كل درجة وظيفية للموظف، مما يسمح بتتبع تاريخ التدرج الوظيفي لكل موظف. جدول الدرجات الوظيفية (Grades): يحتوي هذا الجدول على جميع الدرجات الوظيفية المتاحة في النظام، مما يتيح لك اختيار درجات وظيفية جديدة عند الحاجة. تفاصيل الجداول والعلاقات بينها: 1. جدول الموظفين (Employees) رقم الموظف (EmployeeID): مفتاح أساسي (Primary Key). اسم الموظف (EmployeeName): نص. معلومات شخصية (PersonalInfo): نص. رقم آخر درجة وظيفية (LastGradeID): مفتاح خارجي (Foreign Key) من جدول الدرجات. 2. جدول الدرجات الوظيفية للموظفين (EmployeeGrades) رقم تدرج الدرجة (EmployeeGradeID): مفتاح أساسي (Primary Key). رقم الموظف (EmployeeID): مفتاح خارجي (Foreign Key) من جدول الموظفين. رقم الدرجة الوظيفية (GradeID): مفتاح خارجي (Foreign Key) من جدول الدرجات. تاريخ المنح (GrantDate): تاريخ. 3. جدول الدرجات الوظيفية (Grades) رقم الدرجة الوظيفية (GradeID): مفتاح أساسي (Primary Key). اسم الدرجة الوظيفية (GradeName): نص. العلاقات بين الجداول: جدول الموظفين (Employees) وجداول الدرجات الوظيفية (Grades): علاقة واحد إلى متعدد (One-to-Many) بين LastGradeID في جدول الموظفين و GradeID في جدول الدرجات، مما يتيح ربط كل موظف بأحدث درجة وظيفية له. جدول الموظفين (Employees) وجدول الدرجات الوظيفية للموظفين (EmployeeGrades): علاقة واحد إلى متعدد (One-to-Many) بين EmployeeID في جدول الموظفين و EmployeeID في جدول الدرجات الوظيفية للموظفين، مما يسمح بتتبع تاريخ التدرج الوظيفي لكل موظف. جدول الدرجات الوظيفية (Grades) وجدول الدرجات الوظيفية للموظفين (EmployeeGrades): علاقة واحد إلى متعدد (One-to-Many) بين GradeID في جدول الدرجات و GradeID في جدول الدرجات الوظيفية للموظفين، مما يسمح بتحديد كل درجة وظيفية منحها الموظف في أي وقت. مثالك مع الشرح: لتطبيق هذا التصميم: لكل موظف، سيكون هناك سجل في جدول الموظفين. كل مرة يحصل فيها الموظف على درجة وظيفية جديدة، يُضاف سجل جديد في جدول الدرجات الوظيفية للموظفين، مع الإشارة إلى الموظف والدرجة وتاريخ منح الدرجة. جدول الدرجات الوظيفية يحتوي على قائمة بجميع الدرجات الممكنة والتي يمكنك اختيارها عند تحديث الدرجات الوظيفية للموظفين. بهذه الطريقة، يمكنك بسهولة تتبع معلومات الموظفين وأحدث درجاتهم، بالإضافة إلى تاريخ تدرجهم الوظيفي.

اتفضل هذا الدالة تفي بالغرض ان شاء الله Function ResetAutoNo(ByVal TableName As String, ByVal FieldName As String) On Error GoTo ErrorHandler Dim db As DAO.Database Dim tdf As DAO.TableDef Dim idx As DAO.Index Dim fld As DAO.Field Dim wasPrimaryKey As Boolean Dim pkName As String Set db = CurrentDb Set tdf = db.TableDefs(TableName) wasPrimaryKey = False For Each idx In tdf.Indexes If idx.Primary Then If idx.Fields(0).Name = FieldName Then wasPrimaryKey = True pkName = idx.Name tdf.Indexes.Delete pkName Exit For End If End If Next idx tdf.Fields.Delete FieldName Set fld = tdf.CreateField(FieldName, dbLong) fld.Attributes = fld.Attributes Or dbAutoIncrField tdf.Fields.Append fld If wasPrimaryKey Then Set idx = tdf.CreateIndex(pkName) idx.Fields.Append idx.CreateField(FieldName) idx.Primary = True tdf.Indexes.Append idx End If db.TableDefs.Refresh Set fld = Nothing Set tdf = Nothing Set db = Nothing Debug.Print "تم إعادة تعيين حقل الرقم التلقائي بنجاح" ErrorHandler: If Err.Number = 0 Then ElseIf Err.Number = 3265 Then MsgBox "تحقق من اسم الجدول أو اسم الحقل", vbExclamation, "خطأ" Exit Function ElseIf Err.Number = 3211 Then MsgBox "الجدول تم تحريره او هناك مستخدم يستخدمه", vbExclamation, "خطأ" Exit Function Else MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "خطأ غير متوقع" End If End Function طريقة العمل Call ResetAutoNo("tbl_Name", "ID") على اساس ان ID هو اسم الحقل الترقيم التلقائى و tbl_name هو اسم الجدول

اشكرك على الهدية وشرف لى ان اكون اول المعلقين لكن لو جعلت التصميم والالوان اكثر بساطه (هذا رأي ويمكن تجاهله ولا يعتذ به)(لكن اتمني ان يصلك بكل رحب) لاني صراحه لما فتحت الملف حسيت الامور كاني فى متاهه ومحتاج وقت علشان استوعب من فين يودي على فين 😅 لكن اشكرك على المجهود الرائع وسلمت يمناك

السلام عليكم ورحمة الله تعالى وبركاته اليوم اقدم لكم هدية صغيرة ولكن النفع من ورائها عظيم جدا قد ينتج عن الكود اخطاء عند كتابة الكود قد نحتاج تتبع نتائج الكود قد محتاج معرفة القيم التى يعيدهها الكود قد نكتب استعلام مثلا زنقطع الاسطر ونضيف متغيرات نمرر منها قيما الى الاستعلام ونريد معرفة كبف سوف يراه الحاسوب فى النهاية وقد وقد و ........ الخ وهناك الكثير والكثير وما ذطرته هو فقط على سبيل المثال وليس الحصر اتتنى فكرة وهى كتابة كود فى موديول ليسهل الامور على مصممى قواعد البيانات فيضفى المرونة فى التعامل وكذا الاحترافية التامة مع هذا الامر وهو استخدام: Debug.Print وحتى لا اطيل عليكم اليكم الاكواد Option Compare Database Option Explicit '********************************************************************** ' Function: DebugPrint ' Purpose: Prints a message to the Immediate Window in the VBA editor and optionally logs it to a file. ' Inputs: ' Message - The message to be printed (String). ' Optional AddNewLine - A Boolean flag to add a new line after printing (default is True). ' Optional Prefix - A string to prefix the message (default is ""). ' Optional Suffix - A string to suffix the message (default is ""). ' Optional LogToFile - A Boolean flag to enable logging to a file (default is False). ' Optional FilePath - The path of the file where the log should be saved (default is ""). ' Returns: Nothing - The function performs a print and/or log operation. ' Notes: ' - The function sends the message to the Immediate Window. ' - If AddNewLine is True, a newline is added after the message. ' - Prefix and Suffix can be used to format the message. ' - LogToFile enables logging the message to a specified file. ' - Error handling is included to manage issues with file operations. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub DebugPrint(ByVal Message As String, Optional ByVal AddNewLine As Boolean = True, _ Optional ByVal Prefix As String = "", Optional ByVal Suffix As String = "", _ Optional ByVal LogToFile As Boolean = False, Optional ByVal FilePath As String = "") Dim fullMessage As String Dim fileNum As Integer ' Construct the full message with prefix and suffix fullMessage = Prefix & Message & Suffix ' Print the message to the Immediate Window Debug.Print fullMessage ' Optionally add a newline after printing If AddNewLine Then Debug.Print "" ' Adds an empty line for separation End If ' Log the message to a file if specified If LogToFile And FilePath <> "" Then On Error GoTo ErrorHandler fileNum = FreeFile Open FilePath For Append As #fileNum Print #fileNum, fullMessage Close #fileNum On Error GoTo 0 End If Exit Sub ErrorHandler: ' Handle any errors that occur during file operations Debug.Print "Error occurred while logging to file: " & Err.Description On Error GoTo 0 End Sub ' Example 1: Print a simple message Rem Call DebugPrint("This is a simple message") ' Example 2: Print a message with a prefix and suffix, without adding a new line Rem DebugPrint("Error encountered!", AddNewLine:=False, Prefix:="Error: ", Suffix:=" [Check details]") ' Example 3: Print a message and log it to a file Rem DebugPrint("Logging this message to a file.", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") ' Example 4: Print multiple messages with automatic new lines and logging Rem DebugPrint("Starting process...") Rem DebugPrint("Process in progress...") Rem DebugPrint("Process completed successfully!", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") '--------------------------------------------------------------------------------------------------------------------------------------- '********************************************************************** ' Subroutine: OpenImmediateWindow ' Purpose: Opens the Immediate Window in the VBA editor and prepares it for input. ' Inputs: None ' Returns: Nothing ' Notes: ' - The Immediate Window is activated and ready for input. ' - This subroutine uses the SendKeys method to send keystrokes. ' - Error handling is included to manage potential issues with SendKeys. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Sub OpenImmediateWindow() Dim shell As Object On Error GoTo ErrorHandler ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") With shell ' Send Ctrl+G to open the Immediate Window .SendKeys "^g ", True ' Send Tab to navigate if needed .SendKeys "{TAB}", True End With Application.VBE.MainWindow.Visible = True DoEvents 'this frees up the OS to repaint the screen Exit Sub ' Clean up Set shell = Nothing ErrorHandler: ' Handle any errors that occur during SendKeys operations Debug.Print "Error occurred while opening the Immediate Window: " & Err.Description On Error GoTo 0 End Sub '********************************************************************** ' Function: ClearImmediateWindowContent ' Purpose: Clears the content of the Immediate Window in the VBA Editor. ' Details: ' This function searches for an open Immediate Window within the VBE. ' If found, it sends keystrokes to clear the content using the WScript.Shell object. ' Inputs: None ' Returns: Void ' Error Handling: ' Includes basic error handling to inform the user in case of an issue. ' Notes: ' - This function assumes that there is only one Immediate Window open. ' - The function does not create a new Immediate Window if one is not found. '********************************************************************** Public Function ClearImmediateWindowContent() On Error GoTo ErrorHandler Dim totalVBEWindows As Long Dim currentWindowIndex As Long Const IMMEDIATE_WINDOW_TYPE As Long = 5 ' Type constant for Immediate Window Dim shell As Object ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") totalVBEWindows = Application.VBE.Windows.Count ' Get the number of open windows ' Iterate through all open windows For currentWindowIndex = 1 To totalVBEWindows ' Check if the current window is the Immediate Window If Application.VBE.Windows.Item(currentWindowIndex).Type = IMMEDIATE_WINDOW_TYPE Then Application.VBE.Windows.Item(currentWindowIndex).SetFocus ' Set focus to the Immediate Window ' Ensure the Immediate Window is active If Application.VBE.ActiveWindow.Type = IMMEDIATE_WINDOW_TYPE Then With shell ' Send Ctrl+G to activate the Immediate Window .SendKeys "^g", True ' Send Ctrl+A to select all content .SendKeys "^a", True ' Send Delete to clear selected content .SendKeys "{DEL}", True ' Send Backspace to ensure content is cleared .SendKeys "{BKSP}", True End With Exit Function ' Exit after clearing the content End If Exit For ' Exit the loop if Immediate Window is found and focused End If Next currentWindowIndex ' Clean up Set shell = Nothing Exit Function ErrorHandler: MsgBox "Error occurred while trying to clear the Immediate Window. Error: " & Err.Description, vbCritical ' Clean up Set shell = Nothing End Function '********************************************************************** ' Function: GetDesktopPath ' Purpose: Returns the path to the Desktop for the current user. ' Details: ' This function retrieves the path to the Desktop folder using Windows API functions. ' Inputs: None ' Returns: String - The full path to the Desktop folder. ' Notes: ' - This function uses Windows API to get the Desktop path. ' - Ensure you have error handling to manage unexpected issues. '********************************************************************** Public Function GetDesktopPath() As String Dim strDesktopPath As String Dim objShell As Object On Error GoTo ErrorHandler ' Create an instance of Shell object Set objShell = CreateObject("Shell.Application") ' Get the Desktop folder path strDesktopPath = objShell.NameSpace(&H10&).Self.Path ' Return the path GetDesktopPath = strDesktopPath Exit Function ErrorHandler: MsgBox "Error occurred while retrieving the Desktop path. Error: " & Err.Description, vbCritical GetDesktopPath = "" End Function بالمناسبة لا داعى للقلق من وجود واستخدام "SendKeys" داخل الاكود لانه تم التعامل معها بحرفية تامة كى لا تأثر على حالة الـ Num Lock ImmediateWindowHelper.accdb

تم التعديل على الكود للتسريع فقط. Function getAvgPer(N1 As Double, E1 As Double, Z1 As Double, _ N2 As Double, E2 As Double, Z2 As Double) As Double getAvgPer = (IIf(N1 < N2, N1 / N2, N2 / N1) + _ IIf(E1 < E2, E1 / E2, E2 / E1) + _ IIf(Z1 < Z2, Z1 / Z2, Z2 / Z1)) _ / 3 End Function Function getClosestID(N1 As Double, E1 As Double, Z1 As Double) As Double Dim Sht As Worksheet Dim row As Long, lRow As Long Dim ClosestVal As Double, CurrVal As Double Dim ClosestID As Long Application.ScreenUpdating = False Set Sht = Sheets("1") With Sht lRow = .Range("A1").End(xlDown).row For row = 1 To lRow CurrVal = getAvgPer(N1, E1, Z1, .Cells(row, 2), .Cells(row, 3), .Cells(row, 4)) If CurrVal > ClosestVal Then ClosestVal = CurrVal ClosestID = .Cells(row, 1) If ClosestVal = 1 Then Exit For End If Next row End With getClosestID = ClosestID Set Sht = Nothing Application.ScreenUpdating = True End Function

جرب هدا التعديل Private Sub CommandButton2_Click() ' التحقق من وجود ورقة العمل "Transferts" If Not WorksheetExists("Log") Then MsgBox "غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If ' التحقق من القيم الفارغة If ListBox1.ListIndex = -1 Or (ComboBox3.Value = "" And Me.TextBox1.Value = "") Then Exit Sub If ListBox1.ListIndex <> -1 Then ' التحقق من صحة البيانات If Not IsNumeric(TextBox1.Value) Then MsgBox "الكمية يجب أن تكون رقمًا." Exit Sub End If If ComboBox1.ListIndex = -1 Then MsgBox "يرجى اختيار المخزن الذي سيتم النقل منه." Exit Sub End If Dim wsSales As Worksheet, wsStock As Worksheet Dim lastRowSales As Long, lastRowStock As Long Dim i As Long, j As Long Dim invoiceNo As Long, fromStore As String, toStore As String Dim fromStore1 As Long, toStore2 As Long Dim itemCode As String, quantity As Long, newQuantity As Long Dim quantityDiff As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value fromStore1 = Val(stocktr.Value) toStore2 = Val(stocktrr.Value) Set wsSales = Worksheets("Log") Set wsStock = Worksheets("Inventaire") lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then quantity = wsSales.Cells(i, "J").Value ' الكمية الأصلية newQuantity = Val(TextBox1.Value) ' الكمية المعدلة quantityDiff = newQuantity - quantity ' الفرق بين الكمية الأصلية والمعدلة ' تعديل الكمية في سجل المبيعات wsSales.Cells(i, "J").Value = newQuantity wsSales.Cells(i, "M").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "N").Value = Environ("Username") ' اسم المستخدم ' تحديث المخزون بناءً على الفرق في الكمية lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "B").Value = fromStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value + quantityDiff ' إضافة أو طرح الفرق من المخزن الأصلي ElseIf wsStock.Cells(j, "B").Value = toStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value - quantityDiff ' خصم الفرق من المخزن الآخر wsStock.Cells(j, "M").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "N").Value = Environ("Username") ' اسم المستخدم End If Next j End If Next i MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" Else MsgBox "المرجوا تحديد الصف المراد تعديله", vbCritical, "" End If End Sub

الله ينور عليك يا مايسترو ايه الابداع ده

جرب هذه المحاولة ربما فيها الحل Zone-02-1copy_01.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SAVERANGEPDF() Dim FilePath As String Dim filename As String 'filename = ActiveSheet.Name & "_" & Format(Now, "dd-mm-yyyy") & ".pdf" 'OR filename = ThisWorkbook.Name & "_" & Format(Now, "dd-mm-yyyy") & ".pdf" FilePath = Application.ActiveWorkbook.Path & Application.PathSeparator & filename Selection.ExportAsFixedFormat Type:=xlTypePDF, filename:=FilePath, _ Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True End Sub