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

السلام عليكم ورحمة الله وبركاته هذه دعوة كريمة لتجربة الأداة الجديدة والفريدة من نوعها : دكتور ال VBA وضائف الأداة : 1- تحويل الكود إلى صيغة متوافقة مع النواتين 32 و 64 بت. 2- تصحيح الأخطاء البرمجية في الكود. 3- تنسيق وترتيب الكود شكليا. 4- كتابة التعليقات وشرح للكود باللغتين العربية والإنجليزية. 5- إضافة صائد الأخطاء للكود وذلك لتعقب الأخطاء البرمجية. 6- إضافة ترقيم لأسطر الكود. يمكنك اختيار واحد من هذه الوظائف أو تختار من بينها ما تريده. الأداة مخصصة لأكواد ال VBA وتعتمد على قدرات الذكاء الاصطناعي لإعطاء نتائج دقيقة ومبهرة .. 😁✌🏻 اختصر على نفسك الوقت والجهد واعمل بذكاء 😉👌🏻 رابط الأداة : https://vba-code-doctor-471932697586.us-west1.run.app/ يمكنك فتحها في الهاتف أو الحاسوب على راحتك 😎🌷 جربوها وعطوني رأيكم 😇✌🏻

السلام عليكم بفضل الله تمكنت من ايجاد طريقة ممتازة ومحكمة للتعامل مع توقيع الحضور والانصراف للفترة المسائية الممتدة الى ما بعد منتصف الليل ودخول يوم جديد انتظروني بعض الوقت كي اجري تجاربي النهائية على العمليات وعلى المخرجات .

وعليكم السلام ورحمة الله وبركاته الى جانب الحلول التي ارفقها استاذنا الفاضل hegazee اليك حل اخر بالكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim rngF As Range, rngG As Range Dim rngB As Range, rngC As Range Dim pos As Variant Set rngF = Me.Range("F2") ' Set rngG = Me.Range("G2") Set rngB = Me.Range("B2:B1000") Set rngC = Me.Range("C2:C1000") If Not Intersect(Target, rngF) Is Nothing Then Application.EnableEvents = False pos = Application.Match(rngF.Value, rngB, 0) If Not IsError(pos) Then rngG.Value = Application.Index(rngC, pos) Else rngG.Value = "" End If Application.EnableEvents = True End If rngG.Select End Sub data.xlsb

وعليكم السلام ورحمة الله وبركاته .. أخي بلال أنت عضو فضي ( نتمنى لك المزيد من الدرجات ) ، وما زلت - متأسفاً منك - لا تهتم لأي ملاحظات يتم طرحها خلال المشاركات أو قوانين المنتدى . العنوان :- نكتشف أن مقصده ومعناه مختلف عما تريده أنت . الشرح :- تبخل على أخوانك في المنتدى بالشرح وتكتفي بكلمات لا تتعدى أصابع اليد . إرفاق ملف :- برأيك هل الصورة و 8 كلمات كافيات لتوصيل ما تفكر به لمن يقرأ الموضوع دون ارفاق ملف !!! شكراً لك على رحابة صدرك مراراً وتكراراً في تقبل الملاحظات التي ليس لها هدف إلا أن تحظى بطريق سليم لتوصيل معلومتك

تفضل Sub ToggleColumns() Dim action As String Dim colsInput As String Dim colArray() As String Dim colItem As Variant Dim answer As VbMsgBoxResult Dim invalidInput As Boolean ' مربع حوار لتحديد الإجراء (إخفاء أو إظهار) answer = MsgBox("هل تريد إخفاء الأعمدة؟" & vbCrLf & vbCrLf & "اضغط 'Yes' للإخفاء، 'No' للإظهار.", vbYesNoCancel + vbQuestion, "تحديد الإجراء") If answer = vbCancel Then Exit Sub ' الخروج إذا ضغط المستخدم على "Cancel" ElseIf answer = vbYes Then action = "إخفاء" Else action = "إظهار" End If ' مربع إدخال لطلب الأعمدة من المستخدم colsInput = InputBox("الرجاء إدخال الأعمدة التي تريد " & action & "ها." & vbCrLf & vbCrLf & "أمثلة:" & vbCrLf & "عمود واحد: B" & vbCrLf & "أعمدة متجاورة: B:D" & vbCrLf & "أعمدة متفرقة: B,D,F", "تحديد الأعمدة") ' الخروج إذا كان الإدخال فارغًا If colsInput = "" Then Exit Sub ' إزالة أي مسافات زائدة وتقسيم الإدخال عند الفاصلة colArray = Split(Replace(colsInput, " ", ""), ",") invalidInput = False On Error Resume Next ' تجاهل الأخطاء مؤقتًا للتحقق من صحة الإدخال ' المرور على كل عنصر أدخله المستخدم For Each colItem In colArray If colItem <> "" Then ' التحقق من أن كل جزء من الإدخال يمثل نطاقًا صالحًا If Columns(colItem).Count = 0 Then invalidInput = True Exit For End If End If Next colItem On Error GoTo 0 ' إعادة تفعيل معالجة الأخطاء ' إذا كان هناك إدخال غير صالح، أظهر رسالة خطأ If invalidInput Then MsgBox "الإدخال '" & colItem & "' غير صالح. الرجاء التأكد من إدخال أسماء أعمدة صحيحة.", vbCritical, "خطأ في الإدخال" Exit Sub End If ' تنفيذ الإجراء على كل عمود أو نطاق For Each colItem In colArray If colItem <> "" Then If action = "إخفاء" Then Columns(colItem).Hidden = True Else Columns(colItem).Hidden = False End If End If Next colItem MsgBox "تم " & action & " الأعمدة بنجاح!", vbInformation, "اكتمل الإجراء" End Sub

السلام عليكم ورحمة الله جرب تطبيق هذا التنسيق على التاريخ لعله يفي بالغرض : [$-ar-DZ,201]dddd yyyy/mm/dd

بعد إذن مهندسنا الغالي .. إذا كان ملفك بصيغة Accde فلن تصل للأكواد أبداً .

لا عليك أخي عبداللطيف ، المهم ان المشكلة تم حلها .

تفضل التعديل التالي .. جربه وأخبرني بالنتيجة . 123452025.zip

بارك الله فيكم وينكم من زمان هذا الموضوع طرحته اليوم بعد وصولي لنتيجة صحيحة مرضية بل محكمة هذا الوصول سبقه موضوع تجاوزت المشاركات فيه الــــ 100 لن اتنازل عن اكوادي التي صنعتها .. مادام العمل سليم .. لاني تعبت من التجربة والتكرار والبحث عن الطريقة السليمة ..... ولكن ستبقى هذه الأكواد التي تفضلتم بها مرجعا مهما لي ولغيري لمن اراد بناء برنامج حضور كي يستنير بها حفظكم الله من كل سوء وزادكم علما ورفعة

رداً على هذه النقطة ، وحيث أنه سبق تنفيذها سابقاً .. جرب المرفق نفسه بعد التعديل بحيث سيتم فقط عرض الخطوط العربية ( أو التي تتعامل مع الكاركتر العربي ) في الكومبوبوكس . مع إضافة الفرز التصاعدي للأسماء :- Db3.zip

وانا عند وعدى هذه مشاركتى 1- بعد فك الضغط انقل الصور الى المجلد : TempResources 2- قم بفتح قاعدة البيانات 3- فى المستقبل فقط اضف اى صور الى المجلد : TempResources فى جزء لم انته منه بعد حفظ الاعدادت كقوالب او حفظ الاعدادت لكل شهادة ان اردنا ان تكون كقاعدة بيانات للاحتفاظ بالبيانت وليس مجرد موديولر لعمل الشهادات ويتبقى الجزء الاخير انا افكر فى الطباعة من النموذج الفرعى بشكل مباشر بدون اى تقارير الى لقاء قريب بعد ان اعرف ارائكم فى التطبيق والافكار البسيطة المتواضعة

فكرتي المتواضعة .. dbs2.zip

بل اعجبني المشهد .. سلمت اناملك يا سلام .. زاد حماسي .. احب المفاجآت في مثل هذه المواضيع

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

فضلت ابحث فى المنتدى عن موضوع صفحة رئيسية لاستاذ ابو جودي الى ان وجدت الموضوع طيب المرفق الاول على طريقة ابو جودي والمرفق الثانى من هذا الموضوع والذى يخص الاستاذ Foksh قمت بتعديل بسيط واضافة بسيطة جدا قائمة جانبية على طريقة ابو جودى.zip قائمة جانبية على طريقة الاستاذ Foksh.zip

الملف بعد تحويله لـــ 2003 دون الدخول بأي شئ فقط التحويل . UnMatched.mdb

و عليكم السلام ورحمة الله و بركاته https://www.officena.net/ib/topic/64613-أبغي-قائمة-منسدلة-مرتبطة-بقائمة-منسدلة-أخري-فى-نفس-ورقة-العمل/

مشاركة مع تنفيذ فكرة أستاذنا @kkhalifa1960 ، وبدلاً من الإعتماد على نموذج فرعي للقائمة الفرعية ، هذا تعديل على الفكرة التي تم طرحها سابقاً ، بحيث تم تطبيقها وكأنها Navigation Form .. الملف المرفق :- Menu Navigations.zip

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

انظر الصورة المرفقة للتأكد . لذالك ، وتحقيقاً لنفس الفكرة من زر Open .. استخدمت الدالة التالية :- Public Sub OpenAttachmentFile(ByVal RecordID As Long, Optional ByVal PKFieldName As String = "ID") Dim rs As DAO.Recordset Dim rst As DAO.Recordset2 Dim filePath As String Dim cachePath As String Dim subFolder As String cachePath = Environ("LOCALAPPDATA") & "\Microsoft\Windows\INetCache\" Randomize subFolder = "ACC" & Int((9999 * Rnd) + 1) If Dir(cachePath & subFolder, vbDirectory) = "" Then MkDir cachePath & subFolder End If Set rs = CurrentDb.OpenRecordset("SELECT progIcon FROM tblEnDc WHERE " & PKFieldName & "=" & RecordID) Set rst = rs.Fields("progIcon").Value If Not rst.EOF Then filePath = cachePath & subFolder & "\" & rst.Fields("FileName").Value If Dir(filePath) = "" Then rst.Fields("FileData").SaveToFile filePath End If FollowHyperlink filePath End If rst.Close: Set rst = Nothing rs.Close: Set rs = Nothing End Sub واستدعيها حسب رقم السجل من خلال الزر كما يلي :- Call OpenAttachmentFile(Me.ID) طبعاً اسم المجلد عشوائي لمحاكاة نفس اسلوب آكسيس في السطر subFolder = "ACC" & Int((9999 * Rnd) + 1)

ألف شكر لك حبيب الملايين 😊🌹🌺🌸

الكود في مشاركتي الاخيرة وافي وكافي ... فقط تضاف هذه الجملة عند اغلاق البرنامج لمن اراد حذف الملف FilePath = CurrentProject.Path & "\" & "soccer.png" Result = Dir(FilePath) If Result <> "" Then Kill FilePath End if وهذا يعني انك لم تفهم عني ما اريد راجع نقاشي مع اخونا فادي

Minesweeper.zip

مهو علشان أعرف أفكر وانا بفطر، شجعنا بالهدف المنشود لنحدد الوسيلة التي سنسير بها 😉 . على العموم ، بالنسبة للمطلوب الأول هذه وجهة نظري بالتعديل :- Function RelinkIsIco() As String Dim rs As DAO.Recordset Dim rst As DAO.Recordset2 Dim strFilePath As String Set rs = CurrentDb.OpenRecordset("SELECT progIcon FROM tblEnDc") If Not rs.EOF Then Set rst = rs.Fields("progIcon").Value If Not rst.EOF Then strFilePath = CurrentProject.Path & "\" & rst.Fields("FileName").Value If Dir(strFilePath) <> "" Then Kill strFilePath rst.Fields("FileData").SaveToFile strFilePath RelinkIsIco = strFilePath End If rst.Close: Set rst = Nothing End If rs.Close: Set rs = Nothing End Function مطلوب المسار الوهمي بعتمد تنفيذ فكرته على ماهية حاجتك له وغايتك وهدفك منه .

ما دامه يحقق طلبك وغايتك ، فاعتمده بلا تردد 🙂 .

يا هلا اخوي محمد تغيب وتعود سالما غانما هي وحيدة يتيمة

صحيح 100% يجب التعامل كـــ Fields("FileData") ولكني نسيتها

الحمد لله الذي بنعمته تتم الصالحات

تم الغاء name1 واستبداله باسم الحقل الموجود في الجدول Lieu_Marij في الكود المعدل فنجحت العملية شكرا لك استاذ Foksh ربي يحفظك

تمام استاذنا فوكش

هذا حسابي الاخر من العمل اشكرك معلمنا الغالي @Foksh تم حل المشكلة لما ارجع ع البيت مساءا سأضع اجابة صحيحه

سأوافيك بها غدا بحول الله

مشكلتك اخي الكريم في نسخة الأوفيس نفسها. كل الشكر والتقدير للأستاذ @kkhalifa1960 على مساندته بتحويل النسخة للـ 2003 💐

السلام عليكم عندي كمبيوترين على احد الاجهزة صممت تقرير (شهادة شكر ) وجعلت خلفيته صورة وفي التفاصيل بعض الحقول التقرير ممتاز حتى اني جعلت جميع الهوامش = صفر .. من اجل تمدد الصورة على كامل ورقة الـــ A4 عندما نقلت البرنامج الى الجهاز الآخر تغير تصميم التقرير واختلف تمركز الصورة واختلت اماكن الحقول وظهرت الهوامش كبيرة رغم انها صفر الجهاز الاول win10 والاخر win7 ان كان احد من الاخوة مر بهذه التجربة يفيدني فيها .. جزيتم خيرا

لا أعلم ما السبب حقيقة .. لكن هل عندما تجرب من أجهزة مختلفة تحصل على نفس النتيجة ؟ خطوة عزيزة حبيبنا الغالي 😊🌹 الأداة سرها العجيب هو كود الـ API والمربوط بال Gemini لذلك مثلما لايمكنك فتح الأيميل بدون إنترنت فهذه كذلك 😅 أستخدمها أول الشهر (لما ينزل الراتب وتسدد فاتورة النت) وصبر نفسك آخر الشهر 😂🖐

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

استكملت على الكود السابق لاستاذ @Foksh 😇 Private Sub BMenu1_Click(): ToggleSubMenu "1": Set_Background: Set_Selected_Button_1: End Sub Private Sub BMenu2_Click(): ToggleSubMenu "2": Set_Background: Set_Selected_Button_2: End Sub Private Sub BMenu3_Click(): ToggleSubMenu "3": Set_Background: Set_Selected_Button_3: End Sub Private Sub BMenu4_Click(): ToggleSubMenu "4": Set_Background: Set_Selected_Button_4: End Sub لجعل قائمة الجانبية متلاصقه نوع ما مع اضافة واجهة ويجب تأخير تنقل ل SubForm لون الابيض يكون مخفي بمعدل ثانية يظهر حتى لا تأثر زغللة عين او حل آخر في الامكان تغير المتفرع من الازرار باي تصميم زر بتدريج بكود بسيط مع تفاعل الازرار تحميل المرفق https://www.mediafire.com/file/b6bnzkccf19k8y4/Menu+Navigations.rar/file

عجيب .. عجيب يبدو انك عدلت على شيء ما اعدت التجربة .. والنتيجة كانت مذهلة التعديلات التي اجراها : تنظيم الكود .. بحيث جعل جميع الاعلانات عن المتغيرات في الأعلى بدل شرط الحقل النصي في الدوال بالمتغير وكذلك في جملة sql استبدل الدالة بالمتغير .. عفريت برمجي اضاف لي متغير اسم الموظف غفلت عن نقله من العمل السابق ... هذه الاضافة لا تخطر على بال المحترفين الا بعد عناء اغلاق السجلات عند نهاية كل شرط .. الحقيقة هذه الحركة تحفة هذه صورة من الخيارات التي استخدمتها : وهذا الكود الاصلي : Private Sub id_AfterUpdate() EmpUserid = id Dim mylevl As Boolean mylevl = Nz(DLookup("Emp_user", "tblEmpNames", "Emp_user='" & Me.id & "'"), 0) EmpFatrah = Nz(DLookup("fatrah", "tblEmpNames", "Emp_user='" & Me.id & "'"), 0) If mylevl = False Then Beep Me.LabelH.Caption = "خطأ!! .. الادخال غير صحيح" Me.TimerInterval = 3000 id = "" id.SetFocus Exit Sub End If Dim rs As Recordset Dim strSql As String strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)=funEmpUserid())) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) If rs.RecordCount = 0 Then rs.AddNew rs!EmpUser = id rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update Exit Sub End If Dim waitTime As Integer Dim AdTim As Date waitTime = Nz(DLookup("waitBtween", "tblTimeCtrl"), 0) AdTim = DateAdd("n", waitTime, rs!chekInOut) If Now() < AdTim Then Me.id.SetFocus Beep Me.LabelH.Caption = "توقيع مكرر !! انتظر قليلا ..." id = "" Me.TimerInterval = 3000 id.SetFocus Exit Sub Else If rs!chkio = "I" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "O" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Update Exit Sub ElseIf rs!chkio = "O" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update Exit Sub End If End If End Sub وهذه هي النتيجة الرائعة : Private Sub id_AfterUpdate() Dim EmpUserid As Variant Dim mylevl As Boolean Dim EmpFatrah As Variant Dim rs As DAO.Recordset Dim strSql As String Dim waitTime As Integer Dim AdTim As Date Dim empName As String ' Declare empName EmpUserid = Me.id ' Corrected logic for mylevl to check for user existence mylevl = Not IsNull(DLookup("Emp_user", "tblEmpNames", "Emp_user='" & EmpUserid & "'")) EmpFatrah = Nz(DLookup("fatrah", "tblEmpNames", "Emp_user='" & EmpUserid & "'"), 0) If mylevl = False Then Beep Me.LabelH.Caption = "خطأ!! .. الادخال غير صحيح" Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus Exit Sub End If ' Lookup empName once after confirming user existence empName = Nz(DLookup("Emp_Name", "tblEmpNames", "Emp_user='" & EmpUserid & "'"), "") strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)='" & EmpUserid & "')) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) If rs.RecordCount = 0 Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub End If waitTime = Nz(DLookup("waitBtween", "tblTimeCtrl"), 0) AdTim = DateAdd("n", waitTime, rs!chekInOut) If Now() < AdTim Then Me.id.SetFocus Beep Me.LabelH.Caption = "توقيع مكرر !! انتظر قليلا ..." Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Close Set rs = Nothing Exit Sub Else If rs!chkio = "I" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "O" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub ElseIf rs!chkio = "O" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub End If End If End Sub صحيح هو اضاف لي هذا المتغير : Dim EmpUserid As Variant ولكن هذا المتغير تم الاعلان عنه في الوحدة النمطية كمتغير عام وانا لا الومه لانه لا يعلم وليس له الا الظاهر ☺️

وكمعلومة إضافية في مثال الاخ @محمد التميمي يمكنك الحصول على رقم أي قرص غير الـ C بإستبدال الحرف C بالحرف المطلوب SerialNumber = CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber تحياتي

وعليكم السلام ورحمة الله وبركاته .. لدي دالة تجلب جميع أرقام الهارد ديسك ( القرص الصلب ) حتى لو كان لديك أكثر من هارد موصول على نفس الكمبيوتر .. Public Function GetAllHardDiskSerials() As String On Error GoTo ErrorHandler Dim objWMIService As Object Dim colDisks As Object Dim objDisk As Object Dim result As String Dim i As Integer Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set colDisks = objWMIService.ExecQuery("SELECT * FROM Win32_DiskDrive") i = 1 For Each objDisk In colDisks If Not IsNull(objDisk.SerialNumber) Then Dim serial As String serial = Trim(objDisk.SerialNumber) If serial <> "" Then result = result & "Disk " & i & ": " & serial & vbCrLf i = i + 1 End If End If Next If result = "" Then GetAllHardDiskSerials = "No serial numbers found" Else GetAllHardDiskSerials = result End If CleanUp: Set objDisk = Nothing Set colDisks = Nothing Set objWMIService = Nothing Exit Function ErrorHandler: GetAllHardDiskSerials = "Error" Resume CleanUp End Function أو هذه الدالة البسيطة أيضاً التي تجلب رقم الهارد الذي تم تثبيت نظام التشغيل ويندوز عليه :- Public Function GetHardDiskSerial2() As String On Error GoTo ErrorHandler Dim objWMIService As Object Dim colDisks As Object Dim objDisk As Object Dim strSerial As String Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set colDisks = objWMIService.ExecQuery("SELECT * FROM Win32_DiskDrive") For Each objDisk In colDisks If Not IsNull(objDisk.SerialNumber) Then strSerial = Trim(objDisk.SerialNumber) If strSerial <> "" Then GetHardDiskSerial2 = strSerial Exit For End If End If Next If GetHardDiskSerial2 = "" Then GetHardDiskSerial2 = "Not Found" End If CleanUp: Set objDisk = Nothing Set colDisks = Nothing Set objWMIService = Nothing Exit Function ErrorHandler: Resume CleanUp End Function والإستدعاء فقط في أي مربع نص = اسم الدالة فقط ، كما في الملف المرفق للتوضيح . HD Serial.zip

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

وعليكم السلام نعم يمكنك فمثلا على افتراض ان هذا الحرف موجود بهذا النطاق (A2:H10) فستكون المعادلة كالتالى : =COUNTA(A2:H10)

صحيح تتغير من دون ضغط وفك ولكن لن تستطيع فتح النماذج والتقارير على التصميم ، ولا يمكنك رؤية الأكواد هذا يعني ان الصيغة لم تتغير وانما تغير الامتداد فقط

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

تفضل Suivi des Créances1.xlsx

بارك الله فيك وزادك الله من فضله ورحم الله والديك

وعليكم السلام-تفضل قائمة منسدلة 1مطاطية.xlsx

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