hegazee

و عليكم السلام ورحمة الله و بركاته أخي العزيز محمد لقد طلبت عدة أشياء في بوست سابق لها علاقة بهذا الموضوع و قدمنا بعض الحلول و تم تقديم برنامج بسيط يفي بالغرض و لكنك لم تقم بالرد أو تبدي أي ملاحظة على الملف وهذا يسبب احباط لمن أعد و جهز هذا الملف الذي نبتغي به أولا الأجر من الله سبحانه و تعالى ثم مساعدة الأخوة في هذا المنتدى و الذي تخرج منه أساتذة الأكسيل في الوطن العربي. و لذلك فضلا منك قم بالرد على اي مشاركة لسؤالك خاصة إذا كان الحل مرهق و يستغرق وقتا. جزاك الله الخير الكثير الموضوع موجود في الرابط التالي 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

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

و عليكم السلام ورحمة الله و بركاته جرب الملف المرفق (2)استخراج_فواتير_بدون_تكرار.xlsx

و عليكم السلام ورحمة الله وبركاته حسب فهمي للملف أن الكود يحول البيانات إلى أرقام و تواريخ حسب العمود. و لا أعرف لماذا تمت تسمية زر تشغيل الكود بلصق الاختيارت. قمت بتعديل أشاء بسيطة بالكود للتأكد من تنسيق الخلايا حسب المطلوب بس تأكد من التواريخ المكتوبة يوم و شهر تجرة(2).xlsb

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

حاول ترفع أي ملف فيه مشكله هنا. و إذا كان حجمه كبير ارفعه على جوجل درايف

تفضل الملف . حطيت بعض المعلومات العشوائية لاختبار المعادلة شهر 12022(2).xlsx

من الأفضل رفع ملف ليتم العمل عليه