hegazee

تأكد من إعدادت اللغة للجهاز و أن اللغة العربية ممكنة افتح خيارات الاكسيل و تأكد منها

و عليكم السلام ورحمة الله و بركاته جرب الكود التالي Sub CalculateGenderStats() Dim wsMain As Worksheet Dim wsGender As Worksheet Set wsMain = ThisWorkbook.Sheets("Sheet_Main") Set wsGender = ThisWorkbook.Sheets("Gender Male Female") Dim LastRowMain As Long LastRowMain = wsMain.Cells(wsMain.Rows.count, "A").End(xlUp).Row ' متغيرات للحوالات المصدرة (من العمود I - نوع الراسل) Dim SentMales As Long, SentFemales As Long, SentUnknown As Long Dim SentMalesAmount As Double, SentFemalesAmount As Double, SentUnknownAmount As Double Dim SentMalesClients As Object, SentFemalesClients As Object, SentUnknownClients As Object Set SentMalesClients = CreateObject("Scripting.Dictionary") Set SentFemalesClients = CreateObject("Scripting.Dictionary") Set SentUnknownClients = CreateObject("Scripting.Dictionary") ' متغيرات للحوالات المصروفة (من العمود S - نوع المرسل إليه) Dim PaidMales As Long, PaidFemales As Long, PaidUnknown As Long Dim PaidMalesAmount As Double, PaidFemalesAmount As Double, PaidUnknownAmount As Double Dim PaidMalesClients As Object, PaidFemalesClients As Object, PaidUnknownClients As Object Set PaidMalesClients = CreateObject("Scripting.Dictionary") Set PaidFemalesClients = CreateObject("Scripting.Dictionary") Set PaidUnknownClients = CreateObject("Scripting.Dictionary") Dim i As Long Dim ClientName As String, Gender As String, NationalID As String Dim Amount As Double ' --- تحليل الحوالات المسحوبة (الصادرة) --- For i = 2 To LastRowMain ClientName = Trim(wsMain.Cells(i, "A").Value) NationalID = Trim(wsMain.Cells(i, "B").Value) Gender = Trim(wsMain.Cells(i, "I").Value) Amount = 0 If IsNumeric(wsMain.Cells(i, "F").Value) Then Amount = wsMain.Cells(i, "F").Value ' تجاهل الصفوف الفارغة If ClientName <> "" And NationalID <> "" Then Select Case Gender Case "ذكر" SentMales = SentMales + 1 SentMalesAmount = SentMalesAmount + Amount If Not SentMalesClients.Exists(NationalID) Then SentMalesClients.Add NationalID, 1 Case "أنثى" SentFemales = SentFemales + 1 SentFemalesAmount = SentFemalesAmount + Amount If Not SentFemalesClients.Exists(NationalID) Then SentFemalesClients.Add NationalID, 1 Case Else SentUnknown = SentUnknown + 1 SentUnknownAmount = SentUnknownAmount + Amount If Not SentUnknownClients.Exists(NationalID) Then SentUnknownClients.Add NationalID, 1 End Select End If Next i ' --- تحليل الحوالات المصروفة --- For i = 2 To LastRowMain ClientName = Trim(wsMain.Cells(i, "K").Value) NationalID = Trim(wsMain.Cells(i, "L").Value) Gender = Trim(wsMain.Cells(i, "S").Value) Amount = 0 If IsNumeric(wsMain.Cells(i, "N").Value) Then Amount = wsMain.Cells(i, "N").Value ' تجاهل الصفوف الفارغة If ClientName <> "" And NationalID <> "" Then Select Case Gender Case "ذكر" PaidMales = PaidMales + 1 PaidMalesAmount = PaidMalesAmount + Amount If Not PaidMalesClients.Exists(NationalID) Then PaidMalesClients.Add NationalID, 1 Case "أنثى" PaidFemales = PaidFemales + 1 PaidFemalesAmount = PaidFemalesAmount + Amount If Not PaidFemalesClients.Exists(NationalID) Then PaidFemalesClients.Add NationalID, 1 Case Else PaidUnknown = PaidUnknown + 1 PaidUnknownAmount = PaidUnknownAmount + Amount If Not PaidUnknownClients.Exists(NationalID) Then PaidUnknownClients.Add NationalID, 1 End Select End If Next i ' --- إجماليات --- Dim TotalSent As Long, TotalPaid As Long Dim TotalSentAmount As Double, TotalPaidAmount As Double TotalSent = SentMales + SentFemales + SentUnknown TotalPaid = PaidMales + PaidFemales + PaidUnknown TotalSentAmount = SentMalesAmount + SentFemalesAmount + SentUnknownAmount TotalPaidAmount = PaidMalesAmount + PaidFemalesAmount + PaidUnknownAmount ' --- كتابة النتائج في ورقة Gender Male Female --- ' عناوين الجدول الأول (الحوالات المصدرة) With wsGender .Range("A4:G4").Value = Array("بيان التعاملات", "عدد العمليات", "نسبة العمليات", "عدد عملاء", "نسبة العملاء", "إجمالي المبالغ", "نسبة المبالغ") ' بيانات الذكور (الصادرة) .Range("A5").Value = "ذكر" .Range("B5").Value = SentMales .Range("C5").Value = IIf(TotalSent > 0, SentMales / TotalSent, 0) .Range("D5").Value = SentMalesClients.count .Range("E5").Value = IIf((SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count) > 0, SentMalesClients.count / (SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count), 0) .Range("F5").Value = SentMalesAmount .Range("G5").Value = IIf(TotalSentAmount > 0, SentMalesAmount / TotalSentAmount, 0) ' بيانات الإناث (الصادرة) .Range("A6").Value = "انثي" .Range("B6").Value = SentFemales .Range("C6").Value = IIf(TotalSent > 0, SentFemales / TotalSent, 0) .Range("D6").Value = SentFemalesClients.count .Range("E6").Value = IIf((SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count) > 0, SentFemalesClients.count / (SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count), 0) .Range("F6").Value = SentFemalesAmount .Range("G6").Value = IIf(TotalSentAmount > 0, SentFemalesAmount / TotalSentAmount, 0) ' بيانات غير المحدد (الصادرة) .Range("A7").Value = "غير محدد" .Range("B7").Value = SentUnknown .Range("C7").Value = IIf(TotalSent > 0, SentUnknown / TotalSent, 0) .Range("D7").Value = SentUnknownClients.count .Range("E7").Value = IIf((SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count) > 0, SentUnknownClients.count / (SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count), 0) .Range("F7").Value = SentUnknownAmount .Range("G7").Value = IIf(TotalSentAmount > 0, SentUnknownAmount / TotalSentAmount, 0) ' الإجمالي (الصادرة) .Range("A8").Value = "الاجمالى" .Range("B8").Value = TotalSent .Range("C8").Value = 1 .Range("D8").Value = SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count .Range("E8").Value = 1 .Range("F8").Value = TotalSentAmount .Range("G8").Value = 1 ' عناوين الجدول الثاني (الحوالات المصروفة) .Range("A10:G10").Value = Array("بيان التعاملات", "عدد العمليات", "نسبة العمليات", "عدد عملاء", "نسبة العملاء", "إجمالي المبالغ", "نسبة المبالغ") ' بيانات الذكور (المصروفة) .Range("A11").Value = "ذكر" .Range("B11").Value = PaidMales .Range("C11").Value = IIf(TotalPaid > 0, PaidMales / TotalPaid, 0) .Range("D11").Value = PaidMalesClients.count .Range("E11").Value = IIf((PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count) > 0, PaidMalesClients.count / (PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count), 0) .Range("F11").Value = PaidMalesAmount .Range("G11").Value = IIf(TotalPaidAmount > 0, PaidMalesAmount / TotalPaidAmount, 0) ' بيانات الإناث (المصروفة) .Range("A12").Value = "انثي" .Range("B12").Value = PaidFemales .Range("C12").Value = IIf(TotalPaid > 0, PaidFemales / TotalPaid, 0) .Range("D12").Value = PaidFemalesClients.count .Range("E12").Value = IIf((PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count) > 0, PaidFemalesClients.count / (PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count), 0) .Range("F12").Value = PaidFemalesAmount .Range("G12").Value = IIf(TotalPaidAmount > 0, PaidFemalesAmount / TotalPaidAmount, 0) ' بيانات غير المحدد (المصروفة) .Range("A13").Value = "غير محدد" .Range("B13").Value = PaidUnknown .Range("C13").Value = IIf(TotalPaid > 0, PaidUnknown / TotalPaid, 0) .Range("D13").Value = PaidUnknownClients.count .Range("E13").Value = IIf((PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count) > 0, PaidUnknownClients.count / (PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count), 0) .Range("F13").Value = PaidUnknownAmount .Range("G13").Value = IIf(TotalPaidAmount > 0, PaidUnknownAmount / TotalPaidAmount, 0) ' الإجمالي (المصروفة) .Range("A14").Value = "الاجمالى" .Range("B14").Value = TotalPaid .Range("C14").Value = 1 .Range("D14").Value = PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count .Range("E14").Value = 1 .Range("F14").Value = TotalPaidAmount .Range("G14").Value = 1 ' الإجمالي العام (من B15 إلى G15) .Range("A15").Value = "الإجمالى العام" .Range("B15").Value = TotalSent + TotalPaid .Range("C15").Value = 1 ' النسبة الكلية دائمًا 100% .Range("D15").Value = SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count + PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count .Range("E15").Value = 1 .Range("F15").Value = TotalSentAmount + TotalPaidAmount .Range("G15").Value = 1 End With ' --- تنسيق النسب كنسبة مئوية --- With wsGender .Range("C5:C8, G5:G8").NumberFormat = "0.00%" .Range("C11:C14, G11:G14").NumberFormat = "0.00%" .Range("C15, G15").NumberFormat = "0.00%" .Range("F5:F8, F11:F14, F15").NumberFormat = "#,##0.00" End With MsgBox "تم تحديث تقرير النوع بنجاح!", vbInformation End Sub النسخه النهائيه(2).xlsm

وعليكم السلام ورحمة الله وبركاته الملف المرفق بالمعادلات به كل ما يخص الرقم القومي و حساب السن لطلبة المدارس حساب السن بالرقم القومي.xlsx

أخي محمد المنتدى مليء بالكنوز و ملفات يمكن التعديل عليها بسهولة. مرفق ملف للاستاذ الكبير/ كيماس مع الاستعانة ببعض الأكواد للعلامة خبور. فقط ابحث عن أعمال هؤلاء الأساتذة و غيرهم الكثير مما لا تسعنى الذاكرة لذكرهم سترى و كأنك دخلت مغارة علي بابا. الملف المرفق به فورم مطاطي أي أنك فقط تكتب رؤوس الأعمدة بالعدد الذي تريده و تكتب البيانات و ستجد الفورم تلقائيا مطابق لما كتبته. أتمنى أن نسترجع هذه الملفات و نضيف عليها بعض اللمسات الحديثة وفقا لتطور برنامج الاكسيل و استحداث معادلات جديدة الديناميكى التام لاستعراض السجل وحفظ التغييرات مع الفريمkemas.xlsm

الله يبارك فيك و يعطيك من فضله الكثير

تفضل ملف محدث به كل ما طلبت أما بخصوص تعلم الأكواد فالموضوع بسيط و لكن يلزمه شغف التعلم مع المحاولة و الخطأ أجازات 3.xlsm

و عليكم السلام ورحمة الله و بركاته أخي العزيز محمد لقد طلبت عدة أشياء في بوست سابق لها علاقة بهذا الموضوع و قدمنا بعض الحلول و تم تقديم برنامج بسيط يفي بالغرض و لكنك لم تقم بالرد أو تبدي أي ملاحظة على الملف وهذا يسبب احباط لمن أعد و جهز هذا الملف الذي نبتغي به أولا الأجر من الله سبحانه و تعالى ثم مساعدة الأخوة في هذا المنتدى و الذي تخرج منه أساتذة الأكسيل في الوطن العربي. و لذلك فضلا منك قم بالرد على اي مشاركة لسؤالك خاصة إذا كان الحل مرهق و يستغرق وقتا. جزاك الله الخير الكثير الموضوع موجود في الرابط التالي https://www.officena.net/ib/topic/139393-قاعدة-لاجازات-العاملين/#comment-774531

الحل ممكن من خلال الأكواد: و لكن لا تنسى تفعيل اذهب إلى File > Options > Trust Center > Trust Center Settings ثم اذهب إلى Macro Settings فعل الخيار: "Trust access to the VBA project object model" أولا تضع الكود التالي في الملف الذي تريد التصدير منه ' officena.net Sub ExportAllComponentsDynamically() ' --- هذا الكود يقوم بتصدير جميع المكونات ديناميكيًا --- Dim vbComp As Object ' VBComponent Dim exportPath As String Dim componentName As String Dim fileExtension As String ' 1. حدد مسار التصدير exportPath = "C:\ExcelComponents\" ' 2. تأكد من وجود المجلد If Dir(exportPath, vbDirectory) = "" Then MkDir exportPath End If ' 3. ابدأ الحلقة للمرور على كل مكون في المشروع For Each vbComp In ThisWorkbook.VBProject.VBComponents ' تجاهل المكونات الخاصة بالأوراق (Worksheets) و ThisWorkbook If vbComp.Type = 100 Then ' 100 = vbext_ct_Document GoTo NextComponent End If ' 4. حدد امتداد الملف بناءً على نوع المكون Select Case vbComp.Type Case 1 ' vbext_ct_StdModule fileExtension = ".bas" Case 2 ' vbext_ct_ClassModule fileExtension = ".cls" Case 3 ' vbext_ct_MSForm fileExtension = ".frm" Case Else ' تجاهل الأنواع الأخرى GoTo NextComponent End Select ' 5. احصل على اسم المكون componentName = vbComp.Name ' 6. قم بتصدير المكون بالاسم والامتداد الصحيحين Debug.Print "Exporting: " & componentName & fileExtension vbComp.Export exportPath & componentName & fileExtension NextComponent: Next vbComp MsgBox "تم تصدير جميع المكونات بنجاح إلى: " & exportPath End Sub ثانيا تضع الكود التالي في الملف الذي تريد استيراد العناصر إليه ' officena.net Sub ImportAllComponentsDynamically() ' --- هذا الكود يقوم باستيراد جميع المكونات من مجلد محدد --- Dim importPath As String Dim fileName As String ' 1. حدد مسار الاستيراد importPath = "C:\ExcelComponents\" If Dir(importPath, vbDirectory) = "" Then MsgBox "المجلد المحدد غير موجود!", vbCritical Exit Sub End If ' 2. ابدأ بالبحث عن الملفات fileName = Dir(importPath & "*.*") On Error Resume Next ' لتجاهل الأخطاء (مثل محاولة استيراد مكون موجود) ' 3. ابدأ الحلقة للمرور على كل ملف في المجلد Do While fileName <> "" ' 4. تحقق من امتداد الملف قبل الاستيراد If LCase(Right(fileName, 4)) = ".frm" Or _ LCase(Right(fileName, 4)) = ".bas" Or _ LCase(Right(fileName, 4)) = ".cls" Then Debug.Print "Importing: " & fileName Application.VBE.ActiveVBProject.VBComponents.Import importPath & fileName End If ' انتقل إلى الملف التالي fileName = Dir Loop On Error GoTo 0 MsgBox "اكتملت عملية الاستيراد!" End Sub جرب و أبلغنا بالنتيجة اويمكنك استخدام الكود التالي لاستيراد أي عناصر تريدها مباشرة 'Officena.net Sub ImportComponents() ' --- الإصدار الثالث المصحح: استخدام Or بدلاً من In --- Dim sourceWB As Workbook Dim targetWB As Workbook Dim sourceFilePath As Variant Dim tempFolderPath As String Dim vbComp As Object ' VBComponent Dim componentName As String Dim fileExtension As String Dim fileName As String ' --- 1. الإعدادات الأولية --- sourceFilePath = Application.GetOpenFilename( _ FileFilter:="Excel Macro-Enabled Files (*.xlsm), *.xlsm,All Excel Files (*.xls*), *.xls*", _ Title:="الرجاء اختيار ملف Excel المصدر الذي تريد استيراد المكونات منه", _ MultiSelect:=False) If sourceFilePath = False Then MsgBox "تم إلغاء العملية.", vbInformation Exit Sub End If tempFolderPath = Environ("TEMP") & "\VBA_Import_" & Format(Now, "yyyymmdd_hhmmss") & "\" If Dir(tempFolderPath, vbDirectory) = "" Then MkDir tempFolderPath Set targetWB = ThisWorkbook Application.ScreenUpdating = False ' --- 2. فتح المصدر وتصدير المكونات --- On Error GoTo ErrorHandler Set sourceWB = Workbooks.Open(sourceFilePath, ReadOnly:=True, UpdateLinks:=0) sourceWB.Windows(1).Visible = False For Each vbComp In sourceWB.VBProject.VBComponents If vbComp.Type = 100 Then GoTo NextComponent Select Case vbComp.Type Case 1: fileExtension = ".bas" Case 2: fileExtension = ".cls" Case 3: fileExtension = ".frm" Case Else: GoTo NextComponent End Select componentName = vbComp.Name vbComp.Export tempFolderPath & componentName & fileExtension NextComponent: Next vbComp sourceWB.Close SaveChanges:=False Set sourceWB = Nothing ' --- 3. استيراد المكونات إلى الملف الهدف --- fileName = Dir(tempFolderPath & "*.*") Do While fileName <> "" ' === السطر الذي تم تصحيحه === If LCase(Right(fileName, 4)) = ".frm" Or _ LCase(Right(fileName, 4)) = ".bas" Or _ LCase(Right(fileName, 4)) = ".cls" Then On Error Resume Next targetWB.VBProject.VBComponents.Remove targetWB.VBProject.VBComponents(Left(fileName, InStr(fileName, ".") - 1)) On Error GoTo ErrorHandler targetWB.VBProject.VBComponents.Import tempFolderPath & fileName Debug.Print "تم استيراد: " & fileName End If ' ============================ fileName = Dir Loop ' --- 4. التنظيف --- On Error Resume Next Kill tempFolderPath & "*.*" RmDir tempFolderPath On Error GoTo 0 Application.ScreenUpdating = True MsgBox "اكتملت عملية استيراد المكونات بنجاح من الملف: " & vbCrLf & Mid(sourceFilePath, InStrRev(sourceFilePath, "\") + 1), vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ:" & vbCrLf & Err.Description, vbCritical, "خطأ" If Not sourceWB Is Nothing Then sourceWB.Close SaveChanges:=False If Dir(tempFolderPath, vbDirectory) <> "" Then On Error Resume Next Kill tempFolderPath & "*.*" RmDir tempFolderPath On Error GoTo 0 End If Application.ScreenUpdating = True End Sub Test.xlsm

تفضل الملف جاهز طرح الأيام =DATEDIF(R16;O16;"MD") طرح الشهور =DATEDIF(R16;O16;"YM") طرح السنوات =DATEDIF(R16;O16;"Y") لجمع السنوات =DATE(YEAR(O28) + T28; MONTH(O28) + S28; DAY(O28) + R28) جمع (2).xlsx

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

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

ممكن يكون من إعدادت اللغة فتح: لوحة التحكم > المنطقة (Region) > الإدارة (Administrative) اضغط: تغيير الإعدادات المحلية للنظام (Change system locale...) اختر: العربية (Egypt) أو العربية (Saudi Arabia) حسب منطقتك. أعد تشغيل الجهاز.

تأكد من تمكين الماكرو. الصور غير واضحة ولو أمكن ترفع الملف لمعاينته

تفضل برنامج تصميم سريع لعله يفي بالغرض أجازات 2.xlsm

تفضل https://www.youtube.com/@Emad_ghazi

حل رائع للاستاذ/ محمد إليك حل آخر بالأكواد مع اظهار الكلمات المكررة وعددها الاقتباس 2.xlsm

راجع هذا الرابط https://www.officena.net/ib/topic/114544-تصميم-وعمل-برنامج-كامل-عن-أجازات-الموظفين/#findComment-690656

و عليكم السلام ورحمة الله و بركاته

للأسف، لا يمكن تفعيل وتشغيل أكواد VBA الخاصة ببرنامج Excel مباشرة على جوجل درايف أو داخل جداول بيانات جوجل

آمين، وبارك الله فيكم، ونفعنا الله بما علمنا

تفضل أخي الكريم 3 ملفات الأول إذا كان الأوفيس عندك 365 أو 2016 فيما فوق الثاني إذا كان الأوفيس إصدار أقل من 2016 الثالث باستخدام الأكواد لا تنسى اختيار "اختر تمت الاجابة" إذا تم حل المشكلة استخراج_فواتير_بدون_تكرار (365).xlsx استخراج_فواتير_بدون_تكرار (أوفيس قديم).xlsx استخراج_فواتير_بدون_تكرار (كود).xlsm

جزاك الله خيرا انقر على عبارة اختر تمت الاجابة

أخي @yasse.w.2010أسعدتني كلماتك الطيبة أتمنى لك كل التوفيق، ويارب تلاقي كل الخير في طريقك دايمًا شكرًا أيضًا على ذكرك لأوفيسينا والسادة المشرفين والأعضاء الكرام، ده شرف لنا إننا نقدر نكون مصدر خير ولو بالقليل مع خالص تحياتي

جرب هذا الكود Sub Hyperlink_cut() Dim selectedFile As String Dim result As Variant ' فتح مربع حوار لاختيار الملف With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel المراد قطع الرابط معه" .Filters.Clear .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm" .AllowMultiSelect = False If .Show = -1 Then selectedFile = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف.", vbExclamation Exit Sub End If End With ' محاولة قطع الرابط On Error Resume Next ActiveWorkbook.BreakLink Name:=selectedFile, Type:=xlExcelLinks If Err.Number <> 0 Then MsgBox "تعذر قطع الرابط. تأكد أن الملف مرتبط فعلاً.", vbCritical Exit Sub End If On Error GoTo 0 ' تحديد خلية H9 Range("H9").Select ' تحديد الشكل "Rectangle 4" On Error Resume Next ActiveSheet.Shapes.Range(Array("Rectangle 4")).Select On Error GoTo 0 ' الانتقال إلى المرجع "Macro1" On Error Resume Next Application.Goto Reference:="Macro1" On Error GoTo 0 End Sub

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