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

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

لا أعلم إذا دالة التجميع تراعي قيم الـ Null عليه للاحتراز ممكن نحول الجملة أعلاه إلى: "Nz(Loan_Made, 0) - Nz(Payment_Made, 0)"

لم أنزل المثال ولم أهتم بالنتيجة ولكن أحببت أن أقدم نصيحتي بشأن البحث بقيم التاريخ.

المعذرة، أنصح عند عمليات البحث بتحويل حقول التاريخ إلى رقم طويل Long فهي أكثر أمانا للمبرمج: Private Sub txtMonthe_AfterUpdate() Dim Total As Double Dim EndDate As Long EndDate = CLng(CDate(Me.txtMonthe.Value)) Total = Nz(DSum("Loan_Made - Payment_Made", "tbl_Loans", "Clng(Payment_Month)<=" & EndDate & " AND Loan_ID > 0"), 0) Me.Roming = Format(Total, "Standard") End Sub

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

طيب سوف اعالج طلبك ولكن فضلا لا ترفع مرفقات .. لأن ما اعمل عليه سيختلف

تفضل تم التعديل لم انتبه بسبب ان المعرف تم اخفاؤه inv3.rar

مع انها مش محتاجة IT .. شوف

تفضل أخي @سلمان الشهراني ، تعديلاتي للنقاط ( 1 و 2 و 3 ) فقط !! النقطة 5 لم استفهمها بشكل واضح . تعديلاتي التي تمت :- 1. إضافة مربع نص Zak_Path لتسجيل المسار به عند اختيار ملف القاعدة المستهدفة لترحيل البيانات لها . 2. تم اضافة حقل جديد = Tran من نوع Yes/No في جدول (TBInvoiceMain) في القاعده Zakat1 ، حتى يمييز الفواتير التي تم استرجاعها . بحيث يصبح الحقل (Yes = -1) اذا تم استراجاعه . التعديلات في كود زر الترحيل كالتالي :- Private Sub COM1_Click() On Error GoTo ErrorHandler Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim rstCheck As DAO.Recordset Dim strSQL As String Dim strCheck As String Dim intCount As Integer Dim fd As Office.FileDialog If IsNull(Me.Zak_Path.Value) Or Me.Zak_Path.Value = "" Then Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملف قاعدة البيانات" .Filters.Clear .Filters.Add "قواعد بيانات Access", "*.accdb" .AllowMultiSelect = False If .Show = -1 Then Me.Zak_Path.Value = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف", vbExclamation + vbMsgBoxRight, "" Exit Sub End If End With End If strPath2 = Me.Zak_Path.Value Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strCheck = "SELECT COUNT(*) AS NewCount " & _ "FROM TBInvoiceMain " & _ "WHERE ZatcaXMLSent = -1 AND ID NOT IN " & _ "(SELECT ID FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rstCheck = db1.OpenRecordset(strCheck) If Not rstCheck.EOF Then If rstCheck!NewCount = 0 Then MsgBox "لا توجد فواتير جديدة للترحيل", vbInformation + vbMsgBoxRight, "" GoTo CleanUp End If If MsgBox("سيتم نقل " & rstCheck!NewCount & " فاتورة . هل تريد المتابعة؟", _ vbQuestion + vbMsgBoxRight + vbYesNo, "") = vbNo Then GoTo CleanUp End If End If strSQL = "SELECT DISTINCT TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE ZatcaXMLSent = -1 AND ID NOT IN " & _ "(SELECT ID FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rst1 = db1.OpenRecordset(strSQL) intCount = 0 If Not rst1.EOF Then Do While Not rst1.EOF On Error Resume Next strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "SELECT ID, ID2, InvoiceNumber, FormNumber, InvoiceType, UUID, " & _ "InvoiceSerial, InvoiceDate, InvoiceTime, InvoiceTypeCodeID, " & _ "InvoiceTypeCodeName, InvoiceHash, DateSupply, EndDateSupply, " & _ "PaymentMethod, InstructionNote, TotalDiscount, DiscountReason, " & _ "TaxCode, TaxCodeName, TaxPercentage, InvoiceQR, InvoiceXmlName, " & _ "InvoiceXmlFullPath, EncodedInvoice, XMLCreated, SendingStatus, " & _ "ZatcaStatusCode, ZatcaXMLSent, ZatcaWarningMessage, ZatcaErrorMessage, " & _ "ClearedInvoice, BuyerStreetName, BuyerAdditionalStreetName, " & _ "BuyerBuildingNumber, BuyerPlotIdEntification, BuyerCityName, " & _ "BuyerPostalCode, BuyerCountrySubEntity, BuyerCitySubDivisionName, " & _ "BuyerCompanyName, BuyerTaxNumber, clearedXmlFullPath, BuyerCommercialRegistrationNo " & _ "FROM TBInvoiceMain WHERE ID = " & rst1!ID db1.Execute strSQL If Err.Number = 0 Then strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "SELECT ID, InvoiceNumber, ItemName, Quantity, ItemPriceBeforeTax, " & _ "TaxPercentage, TaxCode, Discount " & _ "FROM TBInvoiceSub WHERE ID = " & rst1!ID db1.Execute strSQL If Err.Number = 0 Then intCount = intCount + 1 End If End If On Error GoTo ErrorHandler rst1.MoveNext Loop strSQL = "DELETE TBInvoiceSub.* " & _ "FROM TBInvoiceSub INNER JOIN TBInvoiceMain ON TBInvoiceMain.ID = TBInvoiceSub.ID " & _ "WHERE DateDiff('d', TBInvoiceMain.InvoiceDate, Date()) > 30" db1.Execute strSQL strSQL = "DELETE TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE DateDiff('d', InvoiceDate, Date()) > 30" db1.Execute strSQL If intCount > 0 Then MsgBox "تم ترحيل " & intCount & " فاتورة بنجاح" & vbCrLf & _ "وتم حذف الفواتير الأقدم من 30 يوم", vbInformation + vbMsgBoxRight, "" Else MsgBox "لم يتم ترحيل أي فواتير", vbInformation + vbMsgBoxRight, "" End If End If CleanUp: If Not rst1 Is Nothing Then rst1.Close If Not rstCheck Is Nothing Then rstCheck.Close Set rst1 = Nothing Set rstCheck = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الترحيل", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub وفي زر الإسترجاع كالتالي :- Private Sub COM1_Click() On Error GoTo ErrorHandler If IsNull(Me.Text1) Or Trim(Me.Text1) = "" Then MsgBox "الرجاء إدخال رقم الفاتورة المطلوب استرجاعها", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If If Not IsNumeric(Me.Text1) Then MsgBox "الرجاء إدخال رقم فاتورة صحيح", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim strSQL As String Dim strPath2 As String Dim lngInvoiceNumber As Long Dim fd As Office.FileDialog Dim intDeletedCount As Integer Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملف قاعدة البيانات" .Filters.Clear .Filters.Add "قواعد بيانات Access", "*.accdb" .AllowMultiSelect = False If .Show = -1 Then strPath2 = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف", vbExclamation + vbMsgBoxRight, "" Exit Sub End If End With lngInvoiceNumber = CLng(Trim(Me.Text1)) Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strSQL = "SELECT COUNT(*) AS InvCount " & _ "FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE ID = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount = 0 Then MsgBox "الفاتورة رقم " & lngInvoiceNumber & " غير موجودة في قاعدة البيانات الثانية", vbExclamation + vbMsgBoxRight, "" GoTo CleanUp End If strSQL = "SELECT COUNT(*) AS InvCount FROM TBInvoiceMain " & _ "WHERE ID = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount > 0 Then If MsgBox("الفاتورة موجودة بالفعل في القاعدة الحالية . هل تريد استرجاعها مرة أخرى؟", _ vbQuestion + vbYesNo + vbMsgBoxRight, "") = vbNo Then GoTo CleanUp End If End If strSQL = "INSERT INTO TBInvoiceMain " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE ID = " & lngInvoiceNumber db1.Execute strSQL strSQL = "INSERT INTO TBInvoiceSub " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "WHERE ID = " & lngInvoiceNumber db1.Execute strSQL strSQL = "UPDATE TBInvoiceMain SET Tran = -1 WHERE ID = " & lngInvoiceNumber db1.Execute strSQL MsgBox "تم استرجاع الفاتورة رقم " & lngInvoiceNumber & " بنجاح", vbInformation + vbMsgBoxRight, "" strSQL = "SELECT COUNT(*) AS OldCount " & _ "FROM TBInvoiceMain " & _ "WHERE DateDiff('d', InvoiceDate, Date()) > 30" Set rst1 = db1.OpenRecordset(strSQL) If rst1!OldCount > 0 Then If MsgBox("يوجد " & rst1!OldCount & " فاتورة مضى عليها أكثر من 30 يوماً . هل تريد حذفها؟", _ vbQuestion + vbYesNo + vbMsgBoxRight, "") = vbYes Then strSQL = "DELETE TBInvoiceSub.* " & _ "FROM TBInvoiceSub INNER JOIN TBInvoiceMain ON TBInvoiceMain.ID = TBInvoiceSub.ID " & _ "WHERE DateDiff('d', TBInvoiceMain.InvoiceDate, Date()) > 30" db1.Execute strSQL strSQL = "DELETE TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE DateDiff('d', InvoiceDate, Date()) > 30" db1.Execute strSQL MsgBox "تم حذف " & rst1!OldCount & " فاتورة قديمة بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "لم يتم حذف الفواتير القديمة", vbInformation + vbMsgBoxRight, "" End If Else MsgBox "لا توجد فواتير مضى عليها أكثر من 30 يومًا", vbInformation + vbMsgBoxRight, "" End If Me.Text1 = "" Me.Text1.SetFocus CleanUp: If Not rst1 Is Nothing Then rst1.Close Set rst1 = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الاسترجاع", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub الملف = Zakat.zip

مشاركة مع اخي فادي ضع المرفق بجانب المجلد ونفذ ملحوظة مهمة : خذ نسخة من مجلدك قبل التنفيذ Private Sub cmd1_Click() RenameSubFolders (CurrentProject.Path & "\New folder") End Sub Sub RenameSubFolders(ByVal MainFolder As String) Dim sSubFolder As String sSubFolder = Dir(MainFolder & "\New folder?*", vbDirectory) Do While sSubFolder <> "" If GetAttr(MainFolder & "\" & sSubFolder) = vbDirectory Then Name MainFolder & "\" & sSubFolder As MainFolder & "\" & Mid$(sSubFolder, 12) End If sSubFolder = Dir() Loop End Sub changeSomeFolderName.rar

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

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

أعتذر من الأستاذ @ناقل ، ولكن الأخ العزيز @abofayez1 ، هل قمت بتجربة الكود الذي اخترته كأفضل إجابة ؟؟؟ هل لديك المكتبة أو قمت بإضافتها Microsoft Forms 2.0 Object Library (MSForms) ؟؟؟؟؟

اخي @هشام جمال الدين الملف المرفق عبارة عن شاشة دخول تتضمن تخويل صلاحية الدخول لاوراق معينة لمستخدم معين عبر تحديد دالك في ورقة صلاحيات باظافة عبارة نعم أو لا في الجدول التالي يمكنك اظافة ملفات أخرى للملف عادي سيتم تحديث أسمائها تلقائيا في عمود A بداية من الصف 6 دون مشاكل بما أنك حدفت جميع الأوراق السابقة والاحتفاظ فقط بالوقة 16 يكفي فقط تعديل الأكواد الخاصة بالدخول لأوراق العمل (مسميات الأوراق) لتفادي ظهور رسالة الخطأ معك أو مراجعة الموضوع الأصلي للتوضيح يمكنك إرفاق الملف المرغوب دمجه ربما نستطيع مساعدتك

السلام عليكم الحمد لله تم اصلاح العطل بالمنتدى بواسطة فلترة البيانات بالعمود الاول A يمكن تعديل حسب العمود الذي به بيانات في الجزء Field:=1 الكود Sub SaveRangeAsPDF() Dim ws As Worksheet Dim savePath As String Set ws = ThisWorkbook.Sheets("ورقة1") With ws .Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>" savePath = "D:\" & .Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf" .Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False .AutoFilterMode = False End With MsgBox "تم حفظ الملف بنجاح!", vbInformation, "حفظ PDF" End Sub الملف DFP2.xlsb

الملف المرفق لاحد الاعضاء يوجد به أكواد للترحيل والاستدعاء يمكننك الاستفادة منه في موضوعك كود ترحيل واستدعاء.xlsm

وعليكم السلام-تفضل لك ما طلبت SOA Yahya1.xlsx

تفضلوا هذا هو الملف بعد اذن الأستاذ محمد فؤاد طبعا لكى تعم الإستفادة للجميع المبيعات و العملاء.xlsm

الكثير يتساءل عن كيفية حساب فاتورة الكهرباء مع شطورها مثلاُ دون 70 كيلو واط السعر 5 جنيه من 71 كيلو واط الى 80 السعر 8 جنيه من 81 كيلو واط الى 200 السعر 15 جنيه من 201 و ما فوق 17 جنيه كيف نحسب الفاتورة اذا كان الاستهلاك 550 كيلو واط مثلاً هذا الملف يجيب عن هذا السؤال الكود Function My_Facture(Myfact As Long, n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer) As Long '''''''''''''''''''''''''''''''''''''''''' Select Case Myfact Case Is <= 70 How_Many = Myfact * n1 Case Is <= 80 How_Many = (70 * n1) + (Myfact - 70) * n2 Case Is <= 200 How_Many = (70 * n1) + (10 * n2) + (Myfact - 80) * n3 Case Is > 200 How_Many = (70 * n1) + (10 * n2) + (120 * n3) + (Myfact - 200) * n4 End Select My_Facture = How_Many '''''''''''''''''''''''''''''''''''''''' End Function الملف مرفق Facture_Electrique.xlsm

استاذ العزيز انظر لهذا الكود في الوحدة النمطية fAdd_Observations لربما يوضح لك بعض الاشياء المخفية ولربما انا لم اوضحها Function Sum_Remaining(p, ID_Emp As Integer, t As String, Loan_ID) As Currency 'On Error Resume Next 'P = DateSerial(Year(P), Month(P), 1) M = Month(p) Y = Year(p) If Loan_ID <> 0 Then If t = "Cridi" Then s = DSum("[Payment_Made]", "tbl_Loans", "[EmployeeID]=" & ID_Emp & " And month([Payment_Month])=" & M & " And Year([Payment_Month])=" & Y & " And [Loan_Type]='Cridi'") End If If t = "Elec" Then s = DSum("[Payment_Made]", "tbl_Loans", "[EmployeeID]=" & ID_Emp & " And month([Payment_Month])=" & M & " And Year([Payment_Month])=" & Y & " And [Loan_Type]='Elec'") End If Else If t = "Inkhirat" Then s = DSum("[Payment_Made]", "tbl_Loans", "[EmployeeID]=" & ID_Emp & " And month([Payment_Month])=" & M & " And Year([Payment_Month])=" & Y & " And [Loan_Type]='Inkhirat'") End If End If If IsNull(s) Then Sum_Remaining = 0 Else Sum_Remaining = s End If End Function