Foksh

تم انشاء دالة للتحديث التلقائي عند فتح الشيت Search في ThisWorkbook كالآتي :- Private Sub Workbook_SheetActivate(ByVal Sh As Object) If Sh.Name = "SEARCH" Then Call UpdateSearchSheet With ThisWorkbook.Sheets("SEARCH") .Range("B5").Select End With End If End Sub وطبعاً دالة التحديث التلقائي :- Sub UpdateSearchSheet() Dim wsSearch As Worksheet Dim wsData As Worksheet Dim wsPensions As Worksheet Dim lastRowData As Long Dim lastRowPensions As Long Dim lastRowSearch As Long Set wsSearch = ThisWorkbook.Sheets("SEARCH") Set wsData = ThisWorkbook.Sheets("DATA") Set wsPensions = ThisWorkbook.Sheets("معاشات") wsSearch.Range("A10:M1000").ClearContents lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row If lastRowData > 9 Then wsData.Range("A10:M" & lastRowData).Copy wsSearch.Range("A10").PasteSpecial xlPasteValues End If lastRowSearch = wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp).Row If lastRowSearch < 10 Then lastRowSearch = 9 lastRowPensions = wsPensions.Cells(wsPensions.Rows.Count, "A").End(xlUp).Row If lastRowPensions > 9 Then wsPensions.Range("A10:M" & lastRowPensions).Copy wsSearch.Range("A" & lastRowSearch + 1).PasteSpecial xlPasteValues End If Application.CutCopyMode = False End Sub وبشكل اختياري ، زر تحديث يدوي :- Sub RefreshSearchData() Call UpdateSearchSheet With ThisWorkbook.Sheets("SEARCH") .Range("B5").Select End With MsgBox "تم تحديث البيانات بنجاح", vbInformation End Sub توحيد البحث في شيت واحد.xlsb

اممممم ، جميل يعني أحسن شيء و الأفضل هو ، أن يتم :- تصميم النماذج المراد استخدامها كـ Popup مسبقاً بهذه الخصائص . استخدام معلمة في OpenArgs لتحديد ما إذا كان النموذج سيفتح كـ Popup أو لا .. في حدث OnLoad للنموذج ، التحقق من OpenArgs وتعديل السلوك حسب الحاجة ( بدون تغيير الخصائص الأساسية ) . أعتقد هذا الحل يتجنب مشاكل الأمان ، وأيضاً يوفر مرونة معقولة ( نسبياً إلى حد ما 😅 ) دون الحاجة لتعديل التصميم أثناء التشغيل .

ما شاء الله تبارك الله !!! ايه التحفة الجميلة دي أداة رائعة بالفعل ومهنية في تنظيم التنقل بين النماذج ، وأعجبتني عدة مميزات فيها :- التصميم المتكامل : التعداد FormOpenMode شامل ويغطي جميع حالات الفتح تقريباً ، مما يجعل الأداء مرناً وقابلاً للتوسعة . وطبعاً التحكم الدقيق من خلال دعم WhereCondition و OpenArgs يضيف طبقة احترافية للتواصل بين النماذج . وهنا تحفة فنية عجبتني كمان وهي منع التكرار من خلال lastCall فكرة ذكية لتجنب إهدار الموارد . بس سؤال خطر على بالي ، وأكيد لم يخف عنك يا تحفتنا هل يمكن إضافة خاصية فتح نموذج كـ "Popup" (نافذة منبثقة) لوضع acWindowNormal مع إمكانية التمرير فوق النماذج الأخرى . جزاك الله خيراً على هذا المجهود ، وجعلها في ميزان حسناتك

حسناً ، سأرى ما يمكنني فعله عند عودتي للمنزل ان شاء الله مساءً .. وقد نبحث عن حل آخر لحل مشكلة تتالي التحديث على البيانات

بارك الله بكم معلمنا الفاضل وأستاذي الجليل ,, قيّمة جداً وثمينة مراجعك التي تشير إليها في مشاركاتك ، وهي ليست بقيمة و نُبل أخلاقكم وعلمكم وعليكم السلام ورحمة الله وبركاته ,, أشكرك أخي على مشاعرك وكلامك اللطيف ،

وعليكم السلام ورحمة الله وبركاته ,, باعتقادي وبرأيي ، يظهر هذا الخطأ لأنه لديك سجلات في جدول الربط TAB_taking_X تحتوي على قيم في حقل BookID لا تتوافق مع أي قيم في حقول ID في الجداول bookX أو bookX2 . قم بحذف بيانات الجداول الثلاثة ، وأعد تطبيق العلاقات ستجد أنها تمت بشكل صحيح .. السبب طبعاً أنه يجب أولا بناء العلاقات قبل ادخال البيانات ليتم الربط فيما بين الجداول حسب شروط العلاقات . أما اذا أردت المحافظة على بياناتك ، فأعتقد عليك إعادة ربط القيم الرقمية بشكل صحيح بشكل يدوي ، ثم لاحظ انك تعتمد على الترقيم التلقائي كرقم فريد للسجل ( وهنا اعتقد انك قد تواجه مشاكل في الترقيم لاحقاً مع تكرار الحذف والإضافة ) . لذا حاول استخدام مثلاً DMAX أو أي ترقيم آخر يكون في حقل مستقل من نوع رقمي بديلاُ عن الترقيم التلقائي في ID في الجدولين bookX أو bookX2 .

وعليكم السلام ورحمة الله وبركاته ,, أشكرك على هذه الثقة أخي الفاضل @algammal ، وأتمنى ان نكون عند حسن الظن بها .. وطبعاً البركة في خبرائكم ومعلمينا الأفاضل هنا ، فأنا ما زلت اكتسب المعلومة في هذا الصرح الكبير . بحد علمي وفهمي البسيط في اكسل ، قمت بدمج بيانات الشيتين (search DATA) و (search معاشات) في الشيت Search . ثم جعلت الفلترة بشكلين ، إما عن موظف محدد باسمه مثلاً أو رقمه القومي كبيانات فريدة ( افتراضاً مني ) ، أو الفلترة الشاملة كما في الصورة :- واستخدمت الماكرو الأول للـ بحث عن سجل محدد :- Sub SearchOne() Dim ws As Worksheet Dim findRange As Range Dim searchCol As Long Dim searchValue As String Dim foundCell As Range Dim lastRow As Long Set ws = ThisWorkbook.Sheets("SEARCH") For searchCol = 1 To 13 If Not IsEmpty(ws.Cells(5, searchCol)) Then searchValue = ws.Cells(5, searchCol).Value lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set findRange = ws.Range(ws.Cells(10, searchCol), ws.Cells(lastRow, searchCol)) Set foundCell = findRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then ws.Range(foundCell.EntireRow.Address).Copy ws.Range("A5").PasteSpecial xlPasteValues Exit For End If End If Next searchCol Application.CutCopyMode = False End Sub وفي زر الفلترة الشاملة :- Sub SearchAlls() Dim ws As Worksheet Dim searchCol As Long Dim searchValue As String Dim lastRow As Long Set ws = ThisWorkbook.Sheets("SEARCH") If ws.AutoFilterMode Then ws.AutoFilterMode = False For searchCol = 1 To 13 If Not IsEmpty(ws.Cells(5, searchCol)) Then searchValue = ws.Cells(5, searchCol).Value lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ws.Range("A9:M" & lastRow).AutoFilter ws.Range("A9:M" & lastRow).AutoFilter Field:=searchCol, Criteria1:=searchValue Exit For End If Next searchCol End Sub وفي زر مسح الفلترة :- Sub ClearSearch() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("SEARCH") If ws.AutoFilterMode Then ws.AutoFilterMode = False ws.Range("A5:M5").ClearContents End Sub هذا بحد فهمي للمطلوب ، وأرجو ان لا أكود قد صوبت إجابتي بشكل بعيد كلياً عن المطلوب ,🙃, الملف بعد التعديل :- توحيد البحث في شيت واحد.xlsb جرب النتائج ، وأخبرني بها .

شكراً لك على الإضافة الجميلة ، وإن شاء الله سأستفيد من هذا الرد في تعديلات الأداة لاحقاً .. طبعاً ومعلومة مهمة بالنسبة لي ، أن الأداة ستحمل اسم فريق المنتدى / قسم آكسيس كاملاً لدعمهم الوفير في المعلومات ..

من تواضع لله رفعه ، وانت من الأساتذة الذين لهم بصماتهم وأسلوبهم

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

أهلا بأخي @ناقل ، يسعدني مرورك وتعقيبك على الموضوع ، رغم انك تسرعت في الحكم علي 😁😁 بالعكس ، أساتذتي الخبراء من المستهدفين بالمشاركة في هذا النقاش ( طبعاً مع احترامي الكامل لحرية ابداء الرأي ) ، انظر .. وتعقيباً على ما أسلفت تالياً :- ففي الحسبان ان شاء الله ، ولكن الصورة والفكرة السابقة من الإصدار الأول للتجارب الأولى لجمع التعليقات والمعلومات التي نستفيد منها .. معلمي الفاضل @ابوخليل ، أُسعد بمشاركتكم ، واتمنى أن أصل في النهاية إلى أداة تحقق الجزء الأكبر من فكرتها وهدفها .. بانتظار توجيهاتكم وإفاداتكم وتصويبكم لي لطرق تسهم في إنجاح المشروع .. معلمي الفاضل @jjafferr ، يسعدني توجيهكم لي بهذه الروابط ، وانا فعلاً قد قرأتها بشكل غير مفصل ، ولكن قراءتي لها كانت محاولة لرسم خطواتي التي سأبدأ بها ، وطبعاً لا بد من تغيير اتجاهي في الوقت الحالي واتجاه بوصلتي ، طبعاً بهدف البدء بخطوات صحيحة تالياً .. أما فيما يخص الكود الذي استخدمته كتجربه ، فيسعدني توجيهك من موقع مايكروسوفت ، دلالة على أن المصادر التي يجب علي اتباع نهجها يجب أن تكون موثوقة لاحقاً .. أخي الأستاذ @kkhalifa1960 ، يسعدني تعليقكم ومروركم ، وإثراءكم وملاحظتكم كثيراً .. ونأمل أن نتعرف على أفكاركم لاحقاً باحثين عن سبيل واسع الأفق لتحقيق المطلوب . أما فيما يخص هذا الجزء .. فطبعاً صديقي وحبيبي @ابو جودي ، من الذين أشاركهم أفكاري وأستنير بتعليقاتهم ، حاله حال أساتذتي ومعلميني الأفاضل ( دون استثناء طبعاً ) . لكن وضعه الحالي الصحي قد يجعل تعليقاته متاحة فيما بيننا خارج المنتدى . ( يعاني من كسر في يده اليمنى حالياً شافاه الله وعافاه شفاء عاجل غير آجل ) . وباسمي وباسم المنتدى نيابةً نتمنى له الشفاء القريب بإذن الله . أشكر لكم جميعاً مروركم وقريباً سنبدأ بطرح الفكرة من بدايتها ( النسخة الأولى من الأداة ) ، ومع توجيهاتكم معلميني وأساتذتي وأخواني ، سنبدأ بتصحيح المسارات الخاطئة عند وجودها وإنجاح الفكرة .

السلام عليكم ورحمة الله وبركاته ،، في طور تحسين الأداة الجديدة ( لم يعلن عنها بعد ) ، للتعامل مع الأكواد التي تعمل على 32 ولا تعمل على 64 ، ما زال العمل جاري على تحسين أداء الأداة ، بحيث من خلال النقاش المفتوح نأتي للوصول الى أفضل أداء ونتيجة . مرفق صورة توضيحية للوضع الحالي للأداة ، مع طرح مثال لكود قبل وبعد التحويل الناتج من الأداة . الكود الذي تمت التجربة عليه كمثال ( لا الحصر ) :- Option Compare Database Option Explicit Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As _ Any) As Long Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub النتيجة من الأداة بعد التحسينات والتعديلات :- 'Code converted to 64-bit compatibility By Foksh ( Officena.Net ) 'Generated on: 2025-05-23 15:22:26 'Tool version: Ver : 1.0 Option Compare Database Option Explicit #If VBA7 Then Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As Long, lParam As Any) As Long #Else Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub باب النقاش مفتوح لأي تعليقات وتوضيحات وتحديثات للجميع .. الأداة حصرية وليس لها أي أساس في أي موقع أجنبي أو عربي ( فقط في أوفيسنا ) *ملاحظة :- الدعوة للنقاش لا تقتصر على من لديه خبرة في آكسيس فقط . أيضاً أخوتنا الأساتذة برتبة ( خبير ) الذين أشعر أنهم غير معنيين بالمشاركة بمواضيع أخوتهم الأساتذة في هذا المنتدى هم معنيين خصوصاً بالمشاركة وإبداء الرأي ، وأرجو ان لا تكون هذه العبارة في غير محلها 😎 . نحن نتكاتف هنا لنتشارك معرفتنا وعلمنا الذي علمنا إياه الله - ولا علم إلا علمه . لذا متأملاً منهم خصوصاً مشاركتنا أفكارهم .

إحدى النكاشات الفكرية التي تدور في رأسي ، على سبيل المثال :- 1. التعامل مع الحمل المتعدد 😅 الولادة تكون أبكر عادة ، فمثلاً:- المعدل الطبيعي للولادة في التوائم = التوأم الثنائي : بين الأسبوع 36–37 التوأم الثلاثي : غالبًا قبل الأسبوع 34 لذا ، ومن وجهة نظري بحكم دراستي للتمريض ، لا يستخدم الأسبوع 40 كموعد قياسي لتقدير الوزن أو الطول . 2. التعامل مع سكري الحمل 😁 دول نقطتين خطروا في بالي ، قلت أسمعهم للهندسة 🤗 . لا أقصد بناءً مشروع كامل ، ولكن تمرين لأصابع ايدك التانية 😇 .

فعلاً ،، أصبت في هذا ، وانا لست معتاداً على هذا السكون 😅 . أما بالنسبة للتكة ، فـ دي حكايتها حكاااااية 🤣 أما بالنسبة للأستاذ @ابو جودي فألف سلامة عليك ، يعاني من كسر في يده اليمنى 🥺، ونتمنى له الشفاء العاجل يارب العالمين. ( يا رب ما كونش فتنت 😇 )

من باب النكاش لا النقاش الى ماذا استندت في :- ' حساب وزن الجنين المتوقع (بناءً على معادلة تقريبية) Select Case Weeks Case 8 To 12 EstimatedWeight = 1 + (Weeks - 8) * 6 ' نمو سريع في الثلث الأول (1-25 جم) Case 13 To 20 EstimatedWeight = 25 + (Weeks - 13) * 40 ' نمو في الثلث الثاني (25-300 جم) Case 21 To 30 EstimatedWeight = 300 + (Weeks - 21) * 80 ' زيادة مطردة (300-1100 جم) Case 31 To 40 EstimatedWeight = 1100 + (Weeks - 31) * 200 ' نمو كبير في الثلث الثالث (1100-3500 جم) Case Else EstimatedWeight = 3500 ' الحد الأقصى التقريبي عند الولادة End Select Me.txtEstimatedWeight = Format(EstimatedWeight, "0") & " جرام" ' حساب طول الجنين المتوقع (بالسنتيمتر) Select Case Weeks Case 8 To 12 EstimatedLength = 2 + (Weeks - 8) * 1.5 ' نمو سريع (2-8 سم) Case 13 To 20 EstimatedLength = 8 + (Weeks - 13) * 2 ' نمو مطرد (8-22 سم) Case 21 To 30 EstimatedLength = 22 + (Weeks - 21) * 2.5 ' زيادة في الطول (22-45 سم) Case 31 To 40 EstimatedLength = 45 + (Weeks - 31) * 0.5 ' نمو بطيء (45-50 سم) Case Else EstimatedLength = 50 ' الحد الأقصى التقريبي عند الولادة End Select Me.txtEstimatedLength = Format(EstimatedLength, "0.0") & " سم" حيث أن هذه المعادلات ليست دقيقة طبياً ، لأن وزن وطول الجنين يعتمدان على عوامل وراثية ، تغذوية ، وصحية للأم . في التطبيقات الطبية الحقيقية ، يتم الاعتماد على جداول معتمدة (مثل منحنيات WHO) أو قياسات السونار .