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

جرب هذه الكود التالى لعله يكون المطلوب Attendance Report Work Sheet.xlsm

أو يمكنك تعديل الكود ليتناسب مع 64bit # if vba7 then declare ptrsafe function.... # else declare function... # end if لاحظ وضع ptrsafe قبل function بالتوفيق

عليكم السلام ورحمة الله وبركاته يمكنك استعمال هذه المعادلة في L6 =IF(H6>0,VLOOKUP(C6,$T$5:$AI$100,MATCH(B6,$T$5:$AI$5,0),0),0) وهذه المعادلة في N6 =IF(AND(H6>0,OR(S6="ض نقل",S6="نقل")),VLOOKUP(C6,$T$5:$AI$100,MATCH(B6,$T$5:$AI$5,0)+1,0),0) لاحظ استعمال match لجلب ؤقم العمود بدلالة رقم أمر التوريد بالتوفيق

الاوفيس الذي قمت بتنصيبه ٦٤ بت قم بحذفه وتنصيب اوفيس ٣٢ بت ليتوافق مع ملفك

وعليكم السلام ورحمة الله وبركاته تفضل اخى جرب الملف الكود فى حدث الشيت Change Private Sub Worksheet_Change(ByVal Target As Range) Dim filterRange As Range Dim dataRange As Range Dim lastRow As Long Dim lastRow2 As Long Application.ScreenUpdating = False If Target.Address = "$P$4" Then lastRow2 = Cells(Rows.Count, "P").End(xlUp).Row Range("P6:V" & lastRow2 + 1).ClearContents If Not IsEmpty(Target.Value) Then lastRow = Cells(Rows.Count, "E").End(xlUp).Row Set dataRange = Range("A6:G" & lastRow) dataRange.AutoFilter Field:=5, Criteria1:="*" & Target.Value & "*" dataRange.Copy Range("P6") dataRange.AutoFilter End If End If Application.ScreenUpdating = True End Sub Data.xlsm

جزاكم الله خيرا اشتغلت فعلا وعملت عليها تعديل بسيط علشان اما الخلية تكون فارغة ميعملش رسالة خطأ هكتبها علشان لو حد حابب يستفيد منها فى خلية سعر الوحدة =IF(ISERROR(VLOOKUP(C6;$T$5:$AI$100;MATCH(B6;$T$5:$AI$5;0);0));0;VLOOKUP(C6;$T$5:$AI$100;MATCH(B6;$T$5:$AI$5;0);0)) فى خلية سعر النقل =IF(AND(L6>0;OR(S6="ض نقل";S6="نقل"));VLOOKUP(C6;$T$5:$AI$100;MATCH(B6;$T$5:$AI$5;0)+1;0);0)

استاذ احمد عبدالحليم و استاذ أ / محمد صالح جزاكم الله خير الجزاء و جعله الله في ميزان حسناتكم

بعد إذن أخي الغالي @احمد عبدالحليم يمكنك استعمال هذا الاجراء لوضع أسماء الشيتات ايا كان عددها في العمود B Sub sheetsnames() n = 4 For Each sh In ThisWorkbook.Sheets If sh.Name <> "الرئيسية" Then Range("b" & n) = sh.Name n = n + 1 End If Next sh MsgBox "ok" End Sub واستعمال هذا الكود في حدث تغيير قيمة الخلايا في شيت الرئيسية Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$2" Then Range("C4:C12").Formula = "=VLOOKUP($B$2,INDIRECT(""'""&B4&""'!a2:b10000""),2,0)" Range("C4:C12").Value = Range("C4:C12").Value End If End Sub بالتوفيق

نسخ لصق هذا كل الموجود في المشروع : 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 Enum RegHive HKEY_CLASSES_ROOT = &H80000000 HK_CR = &H80000000 HKEY_CURRENT_USER = &H80000001 HK_CU = &H80000001 HKEY_LOCAL_MACHINE = &H80000002 HK_LM = &H80000002 HKEY_USERS = &H80000003 HK_US = &H80000003 HKEY_CURRENT_CONFIG = &H80000005 HK_CC = &H80000005 HKEY_DYN_DATA = &H80000006 HK_DD = &H80000006 End Enum Enum RegType REG_SZ = 1 REG_BINARY = 3 REG_DWORD = 4 End Enum 'Public Const ERROR_SUCCESS = 0& Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long Private Function CreateRegKey(hKey As RegHive, strPath As String) Dim hCurKey As Long Dim lRegResult As Long lRegResult = RegCreateKey(hKey, strPath, hCurKey) If lRegResult <> ERROR_SUCCESS Then 'there is a problem End If lRegResult = RegCloseKey(hCurKey) End Function Private Function SaveRegLong(ByVal hKey As RegHive, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long) Dim hCurKey As Long Dim lRegResult As Long lRegResult = RegCreateKey(hKey, strPath, hCurKey) lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, 4) If lRegResult <> ERROR_SUCCESS Then End If lRegResult = RegCloseKey(hCurKey) End Function Private Sub Timer1_Timer() Dim strVM As String Dim strVS As String On Error Resume Next 'strVM = SaveRegLong(HKEY_LOCAL_MACHINE, "Software\Microsoft\Office\11.0\Access\Security", "Level", 1) 'strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Access\Security", "Level", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\12.0\Access\Security", "VBAWarnings", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\14.0\Access\Security", "VBAWarnings", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\15.0\Access\Security", "VBAWarnings", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\16.0\Access\Security", "VBAWarnings", 1) Unload Me End Sub

وعليكم السلام ورحمة الله وبركاته تفضل اخى جرب الملف =IF(R3*24 < 8;"";INT(R3*24/8)) هذه المعادلة لحساب الايام واليوم = 8 ساعات وتم الضرب فى 24 وهو عدد ساعات اليوم الواحد ولتحويل الوقت الى رقم والدالة INT للحصول على الرقم الصحيح بدون كسر =IF(R3*24<8;R3;R3-S3*8/24) وهذه المعادلة لحساب عدد الساعات الباقية من الايام Book7.xlsx

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

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مكتبة الأكواد الخاصة) :: الإصدار الثالث :: مكتبة عامرة بمئات الأكواد VBA داعمة للمبرمجين وجزء لا يتجزأ من عملهم. تختصر الوقت وتسهل العمل على مصممي البرامج. وهي مكتبة عامة يمكن استخدامها لأي لغات برمجية أخرى . من مميزات المكتبة : - أكثر من 360 كود ودالة في مختلف الفنون والمجالات . - قابلة لحفظ مرفقات مع الكود لدعم التطبيق. - يمكنك إضافة أكوادك الخاصة لتكون مكتبة داعمة لكل مبرمج. - سهلة الاستخدام . تحميل المكتبة : مكتبة الأكواد الخاصة zip.zip ولا تنسوني من صالح دعواتكم 🙂🌹

استاذنا الفاضل ومعلمنا @أ / محمد صالح حل اكثر من رائع وغاية السهولة واليسر تقبل تحياتى

نظام جهازي يستعمل الفاصلة بين أجزاء المعادلة ربما يكون جهازك يستعمل الفاصلة المنقوطة

عليكم السلام myTxtSahm=fnAreaSahm([حقل المجموع الكلي(اسهم)]) myTxtQerat=fnAreaQerat([حقل المجموع الكلي(اسهم)]) myTxtFdan=fnAreaFdan([حقل المجموع الكلي(اسهم)]) اتمنى ان هذا واضح باعتبار myTxtSahm هو حقل الاسهم في التقرير و myTxtQerat هو حقل القراريط التقرير و myTxtFdan هو حقل الأفدنة في التقرير

تسلم ايدك بجد هو دا فعلا اللي كنت محتاجه بالظبط ربنا يبارك فيك

هذه معادلة بحث عادية لماذا تجعلها مصغوفات بالضغط على Ctrl+shift+enter يلزمك تقليل عدد صفوف البحث بتبديل رقم 1048576 إلى 1000 مثلا إذا كانت صفوف بياناتك أقل من الف صف او اكبر من عدد صفوف البيانات لديك بقليل بالتوفيق

الف شكر لحضرتك ع المجهور الرائع جزاك الله خير

تصميم جميل وألوان هادئة 🙂

'strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Access\Security", "Level", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\12.0\Access\Security", "VBAWarnings", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\14.0\Access\Security", "VBAWarnings", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\15.0\Access\Security", "VBAWarnings", 1) strVS = SaveRegLong(HKEY_CURRENT_USER, "Software\Microsoft\Office\16.0\Access\Security", "VBAWarnings", 1) برنامج التحزيم يخدم بعدة اشياء : منها تشغيل التطبيقات اثناء التنصيب او بعد الانتهاء ومنها تنفيذ الأوامر كتسجيل المكتبات ونحوه . ولكني لا حظت في الآونة الاخيرة قوة حماية وندوز .. وعدم السماح للبرامج العادية بتجاوز الحماية خاصة فيما يخص ملفات النظام اللي اقصده انه يكون في ملف التعديل اوامر تتجاوز حماية وندوز ، وكما ترى الملف يقوم بالتعديل على الريجستري ، ورقم واحد في سطر الكود يمثل درجة امان الماكرو ، والارقام من 11 الى 16 تمثل اصدارة اكسس . لا .. لا يشترط .. فبعض الملفات يتيح لنا برنامج التحزيم من توجيهها الى المجلدات المؤقته انا اجعل هذا الملف اعلاه ضمن مجلد البرنامج فقد يحتاجه العميل فيما لو قام بتنصيب اوفيس جديد

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

تفضل اخى مطلبك على الملف الذى ارفقته سابقا بعد توضيح المطلوب DataBASE2.xlsm ولكن اذا كان غياب الموظف اكثر 7 ايام سوف يحدث خطأ بسبب التنسيقات حيث ان الجداول اسفل بعضها فى شيت Abs لذلك اليك حل اخر بحيث تكون الجداول لانواع الاجازات بجوار بعضها البحث برقم الموظف .xlsm فى كلا الملفين اكتب رقم الموظف سوف تحصل على الاجازات تقبل تحياتى

هنا الحل أو ضع مثال للعمل عليه

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

جميل جدا جدا جدا الله يفتح عليك لقد استفدت جدا من فكرتك وسوف اطبقها جزاك الله كل خير ـ ورحم الله والديك فى الدنيا والاخره شكرى وتقديرا لكم واحترامى

يمكنك الاستفادة من هذا الموضوع بالنسبة للبحث بمجرد كتابة حرف بالتوفيق

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

جرب الكود التالى Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$8" Or Target.Address = "$F$8" Then Dim LastRow As Long Dim FilterRange As Range Dim FilterColumn As Long If Target.Address = "$D$8" Then FilterColumn = 2 ElseIf Target.Address = "$F$8" Then FilterColumn = 4 End If LastRow = Me.Cells(Rows.Count, "D").End(xlUp).Row Set FilterRange = Range("C9:U" & LastRow) If Not IsEmpty(Target.Value) Then FilterRange.AutoFilter Field:=FilterColumn, Criteria1:=Target.Value Else FilterRange.AutoFilter Field:=FilterColumn End If End If End Sub

جرب هذ التعديل لا فائدة من السطر الاول في بداية الكود لقد قمت بازالته عند وضع احد الخلايا سيتم الفلترة وعند مسح الخلية سيتم عرض البيانات الكلية Private Sub Worksheet_Change(ByVal Target As Range) Dim LastRow As Long Dim FilterRange As Range LastRow = Me.Cells(Rows.Count, "D").End(xlUp).Row Set FilterRange = Range("C9:U" & LastRow) If Me.FilterMode Then Me.ShowAllData If Not IsEmpty(Range("D8")) Then FilterRange.AutoFilter Field:=2, Criteria1:=Range("D8").Value ElseIf Not IsEmpty(Range("E8")) Then FilterRange.AutoFilter Field:=4, Criteria1:=Range("E8").Value End If End Sub

كتعديل في كود الفلتر وعدم الحاجة لكود إلغاء الفلتر يمكن استعمال هذا الكود في حدث تغيير محتوى الخلايا في الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$8" Then Dim LastRow As Long Dim FilterRange As Range LastRow = Me.Cells(Rows.Count, "D").End(xlUp).Row Set FilterRange = Range("C9:U" & LastRow) If Not IsEmpty(Range("D8")) Then FilterRange.AutoFilter Field:=2, Criteria1:=Range("D8").Value Else FilterRange.AutoFilter Field:=2 End If End If End Sub بالتوفيق

وعليكم السلام تفضل اخى جرب الملف التالى FilterData.xlsm

الشكر الكثير لك استاذنا موسى على المرفق الجميل والمهم لكل مبرمج ومتعلم فعلاً يحتاجه الكثير منا بارك الله فيك وزاد من امثالك وجعله في موازين حسناتك اخوك فؤاد

أستاذي ومعلمنا العزيز @ابوخليل .. وأنا يشرفني كثيرا أنك أول الحضور والمعلقين 🙂 🌹 عمت الفرحة وزاد الهنا ☺️ أجاب الله دعواتك .. وعمت بركاتك .. ونفعنا الله بك .. وحفك التوفيق والتسديد 🤲🏻

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

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

تفضل هذا مثال قمت بإعداده للإتصال بقاعدة البيانات يجب تقسم قاعدة البينات لديك في مشروعك ثم الاتصال بقاعدة البيانات في السيرفر او الجهاز المحلي الذي ستحتفظ بقاعدة البيانات به ( الجداول ) في المثال لدينا ثلاث قواعد بيانات + الواجهة من خلال الواجهة سنقوم بالتالي - انشاء مجلد للنسخة الاحتياطية - سيتم حفظ نسخة جديدة عند تسجيل كل قاعدة بيانات - يجب بعد تسجيل النسخة ان تقوم بالإتصال بقاعدة البيانات تم ترقم الخطوات ليسهل التجربة و لكن يجب فك الضغط اولا قبل الاستخدام بعد تسجيل النسخة و الاتصال بها ستكون بهذا الشكل StrData.zip

اخي شاهد المرفق _Arabic g11 V1.xlsm

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

Try this File My_sarch.xlsm