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

تفضل الشرح بالتفصيل الشرح استعنت بالذكاء الاصطناعي الهدف من هذا الكود هو البحث عن اسم معين في ورقة عمل تسمى “السجل” وعند العثور عليه، نسخ مجموعة من البيانات المرتبطة بهذا الاسم إلى ورقة عمل أخرى تسمى “استدعاء”. إليك الخطوات الرئيسية التي يقوم بها الكود لتحقيق هذا الهدف: مراقبة التغييرات في الخلية B6 في ورقة “استدعاء”. البحث عن الاسم المدخل في الخلية B6 داخل العمود B في ورقة “السجل”. نسخ البيانات المرتبطة بالاسم الموجود في ورقة “السجل” إلى مواقع محددة في ورقة “استدعاء”. إذا تم العثور على الاسم، يتم نسخ البيانات إلى الصفوف 9، 12، 15، و18 في ورقة “استدعاء”. إذا لم يتم العثور على الاسم، يتم عرض رسالة تفيد بأن الاسم غير موجود في السجل If Not foundCell Is Nothing Then هذا السطر يتحقق مما إذا كانت الخلية foundCell تحتوي على قيمة أم لا. إذا كانت foundCell تحتوي على قيمة، فهذا يعني أن الاسم الذي تم البحث عنه قد تم العثور عليه في العمود B في الورقة “السجل”. إذا لم يتم العثور على الاسم، فإن foundCell ستكون Nothing. نسخ البيانات إلى الصف 9: data = wsSource.Range(foundCell.Offset(0, 1), foundCell.Offset(0, 10)).Value wsTarget.Range("A9:I9").Value = data foundCell.Offset(0, 1) تعني الانتقال من الخلية التي تم العثور عليها بمقدار عمود واحد إلى اليمين. foundCell.Offset(0, 10) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 10 أعمدة إلى اليمين. يتم نسخ البيانات من العمود الثاني إلى العمود الحادي عشر في الصف الذي تم العثور فيه على الاسم إلى الصف 9 في الورقة “استدعاء”. نسخ البيانات إلى الصف 12: data = wsSource.Range(foundCell.Offset(0, 10), foundCell.Offset(0, 19)).Value wsTarget.Range("A12:I12").Value = data foundCell.Offset(0, 10) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 10 أعمدة إلى اليمين. foundCell.Offset(0, 19) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 19 عمودًا إلى اليمين. يتم نسخ البيانات من العمود الحادي عشر إلى العمود العشرين في الصف الذي تم العثور فيه على الاسم إلى الصف 12 في الورقة “استدعاء”. نسخ البيانات إلى الصف 15: data = wsSource.Range(foundCell.Offset(0, 19), foundCell.Offset(0, 28)).Value wsTarget.Range("A15:I15").Value = data foundCell.Offset(0, 19) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 19 عمودًا إلى اليمين. foundCell.Offset(0, 28) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 28 عمودًا إلى اليمين. يتم نسخ البيانات من العمود العشرين إلى العمود التاسع والعشرين في الصف الذي تم العثور فيه على الاسم إلى الصف 15 في الورقة “استدعاء”. نسخ البيانات إلى الصف 18: data = wsSource.Range(foundCell.Offset(0, 28), foundCell.Offset(0, 38)).Value wsTarget.Range("A18:I18").Value = data foundCell.Offset(0, 28) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 28 عمودًا إلى اليمين. foundCell.Offset(0, 38) تعني الانتقال من الخلية التي تم العثور عليها بمقدار 38 عمودًا إلى اليمين. يتم نسخ البيانات من العمود التاسع والعشرين إلى العمود الثامن والثلاثين في الصف الذي تم العثور فيه على الاسم إلى الصف 18 في الورقة “استدعاء”. إذا لم يتم العثور على الاسم: Else MsgBox "الاسم غير موجود في السجل." End If إذا لم يتم العثور على الاسم، يتم عرض رسالة تفيد بأن الاسم غير موجود في السجل

جزاك الله خير

السلام عليكم انظر للمرفق لعل يكون طلبك البحث بحسب الفلترة.accdb

مضبوط تسلم 100 %

وعليكم السلام ورحمة الله وبركاته الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$6" Then Application.ScreenUpdating = False Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim nameToFind As String Dim foundCell As Range Dim data As Variant Set wsSource = ThisWorkbook.Sheets("السجل") Set wsTarget = ThisWorkbook.Sheets("استدعاء") nameToFind = wsTarget.Range("B6").Value Set foundCell = wsSource.Range("B:B").Find(What:=nameToFind, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then data = wsSource.Range(foundCell.Offset(0, 1), foundCell.Offset(0, 10)).Value wsTarget.Range("A9:I9").Value = data data = wsSource.Range(foundCell.Offset(0, 10), foundCell.Offset(0, 19)).Value wsTarget.Range("A12:I12").Value = data data = wsSource.Range(foundCell.Offset(0, 19), foundCell.Offset(0, 28)).Value wsTarget.Range("A15:I15").Value = data data = wsSource.Range(foundCell.Offset(0, 28), foundCell.Offset(0, 38)).Value wsTarget.Range("A18:I18").Value = data Else MsgBox "الاسم غير موجود في السجل." End If Application.ScreenUpdating = True End If End Sub الملف كود استدعاء بيانات1.xlsm

الفكرة بالنسبة للمبيعات هي عند اختيار اسم صفحة المخزون من الخلية C3 سيتم انشاء قائمة منسدلة بأكواد الصنف المتوفرة في نفس الصفحة المختارة تلقائيا لتسهيل عملية البحث وعند اختيار كود الصنف يتم جلب اسم الصنف وبعد ادخال السعر والملاحظات والظغط على زر الترحيل يتم ترحيل بيانات التسجيل الى الصفحة المختارة مع ترحيل نفس البيانات الى ورقة المبيعات في الاعمدة المناسبة و اظافة تاريخ اليوم في العمود الاول من الجدول المشتريات بعد تحديد الصفحة الهدف من الخلية G3 واظافة بيانات التسجيل كود الصنف- اسم الصنف-السعر-الملاحظات يتم ترحيلها الى الصفحة المحددة مع نسخ نفس البيانات المتاحة لجدول المشتريات في الاعمدة المناسبة ادا كانت قد فهمت طلبك بشكل صحيح فهدا سيوفي بالغرض تم دمج اكواد الترحيل لجميع الصفحات في الكود التالي Sub CopyDatasale() Call ProcessTransfer("تسجيل", "المبيعات", Array(1, 2, 7, 8), Array(2, 3, 8, 9), True) End Sub Sub CopyDatabuy() Call ProcessTransfer("تسجيل", "المشتريات", Array(1, 2, 7, 8), Array(1, 2, 7, 8), False) End Sub '======================================= Sub ProcessTransfer(registrationSheetName As String, destName As String, _ stockColumnsArr As Variant, salesColumnsArr As Variant, Cnt As Boolean) Dim WS As Worksheet, f As Worksheet, dest As Worksheet Dim arr As Variant, list As String, MSg As VbMsgBoxResult Dim i As Long Set WS = ThisWorkbook.Sheets(registrationSheetName) Set dest = ThisWorkbook.Sheets(destName) If destName = "المشتريات" Then arr = Array(WS.[G4], WS.[G5], WS.[G6], WS.[G7]) list = WS.[G3].Value Else arr = Array(WS.[C4], WS.[C5], WS.[C6], WS.[C7]) list = WS.[C3].Value End If For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه" arr(i).Select Exit Sub End If Next On Error Resume Next Set f = ThisWorkbook.Sheets(list) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & list & " غير موجودة", vbExclamation Exit Sub End If If MsgBox("ترحيل البيانات؟", vbYesNo + vbQuestion, "تأكــيد") = vbNo Then Exit Sub RegistrationData f, arr, stockColumnsArr RegistrationData dest, arr, salesColumnsArr, Cnt MsgBox list & ": تم ترحيل البيانات بنجاح إلى " & destName & " وقائمة المخزون", vbInformation MSg = MsgBox("هل ترغب في إفراغ بيانات التسجيل؟", vbYesNo + vbQuestion, "تفريغ الخلايا") If MSg = vbYes Then If destName = "المشتريات" Then WS.[G3:G7].ClearContents Else WS.[C3:C7].ClearContents End If End If End Sub '======================================= Sub RegistrationData(sheet As Worksheet, arr As Variant, columnsArr As Variant, Optional Cnt As Boolean = False) Dim tbl As ListObject, lige As Range, TabBD As Range, i As Long Set tbl = sheet.ListObjects(1) Set lige = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) Set TabBD = IIf(lige Is Nothing, tbl.ListRows(1).Range, lige.Offset(1)) If Cnt Then TabBD.Cells(1, 1).Value = Format(Date, "dd/mmmm") End If For i = LBound(arr) To UBound(arr) TabBD.Cells(1, columnsArr(i)).Value = arr(i).Value Next i End Sub وفي حدث ورقة التسجيل ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim dest As Worksheet, i As Long, lastRow As Long, TabBD As Boolean, Sh As String, itemCode As String, _ dict As Object, CRng As Range, a As Variant, tmp As Variant Dim WS As Worksheet: Set WS = Sheets("تسجيل") On Error GoTo ErrorHandler Sh = Me.Range("C3").Value itemCode = Me.Range("C4").Value TabBD = False If Sh = "" Then Exit Sub Application.ScreenUpdating = False Application.EnableEvents = False Select Case Target.Address Case Me.Range("C3").Address If Not Check(Sh, dest) Then TabBD = True Else lastRow = dest.Cells(dest.Rows.Count, "C").End(xlUp).Row Set CRng = dest.Range("C4:C" & lastRow) tmp = CRng.Value Set dict = CreateObject("Scripting.Dictionary") For i = 1 To UBound(tmp, 1) If tmp(i, 1) <> "" And Not dict.Exists(tmp(i, 1)) Then dict.Add tmp(i, 1), Nothing End If Next i With WS.Range("L3:L" & WS.Cells(WS.Rows.Count, "L").End(xlUp).Row) .ClearContents End With If dict.Count > 0 Then With WS.Range("L3").Resize(dict.Count) .Value = Application.Transpose(dict.Keys) End With End If WS.Range("C4:C5").Value = "" Call Add_listeDéroulante End If Case Me.Range("C4").Address If Sh = "" Or itemCode = "" Then TabBD = True Else If Not Check(Sh, dest) Then TabBD = True Else lastRow = dest.Cells(dest.Rows.Count, "C").End(xlUp).Row Set CRng = dest.Range("C4:C" & lastRow) tmp = CRng.Value a = Application.Match(itemCode, Application.Index(tmp, 0, 1), 0) If Not IsError(a) Then WS.Range("C5").Value = dest.Cells(a + 3, "D").Value Else WS.Range("C5").Value = "" TabBD = True End If End If End If End Select ExitHandler: Application.EnableEvents = True Application.ScreenUpdating = True Exit Sub ErrorHandler: MsgBox "Error : " & Err.Description, vbExclamation TabBD = True Resume ExitHandler End Sub Function Check(sheetName As String, ByRef dict As Worksheet) As Boolean On Error Resume Next Set dict = Sheets(sheetName) On Error GoTo 0 If dict Is Nothing Then MsgBox "غير موجودة" & " " & sheetName & " : " & "الصفحة", vbExclamation Check = False Else Check = True End If End Function مبيعات ومشتريات.xlsb

ربما يرجع السبب لأن معادلة filter و xloojup توجد في الإصدارات الحديثة فقط من أوفيس 2021 وما بعدها أو 365 مثلا

وعليكم السلام ورحمة الله وبركاته الكود Sub CountIfToColumnH() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row For i = 2 To lastRow ws.Cells(i, "H").Value = Application.WorksheetFunction.CountIf(ws.Range("G$2:G" & i), ws.Cells(i, "G").Value) Next i End Sub الملف TEST COUNTIF.xlsb

::بسم الله نبدأ:: السلام عليكم ورحمة الله وبركاته اخوتي الكرام كل عام وانتم بخير اليوم وكما هو موضع من عنوان الموضوع موضوعنا عن ربط برنامج الاكسيس بصفحات الويب وهنا اخص لغة ال PHP كان فى سائل عن امكانية ربط برنامج الاكسيس بالنت علشان يسمح للمرضي بتحميل التقارير الخاصه بهم ورديت عليه تقريبا ان الموضوع صعب لكن اليوم اقدم لكم طريقه اتمني ان تكون سهله وواضحه واعذروني على المقدمة الطويله ورقاقة الكلمات نبدأ اولا بالادوات الازم توفرها:- 1- XAMPP يمكن تحميله من هنا 2- Connector/ODBC MYSQL يمكن تحميله من هنا ويفضل تنزيل النسخه 8.0.31 انا عن نفسي شغال بالاصدار 8.0.31 (وشغال تمام) وممكن تحمله من هنا للنسخه 32بت ومن هنا للنسخه 64بت 3- ActiveX WebBrowser control (antview) يمكن تحميل هذه الاداة من هنا او رابط مباشرة من هنا 4- PHP File's & Access File هنا يمكن تحميل الملفات التى قمت بالعمل عليها :: نبدأ بتسطيب برنامج XAMPP :: وهو المحاكي الذى سيعمل فيه بيئة ملفات ال php طبعا المفترض ان هناك دومين موجود بالفعل واستضافة والذى سيتم تنصيب الخدمه عليه وعن طريقها سيكون متاح للمريض ان يحمل تقريره لكن الموضوع هنا للتعليم فنبدأ اولا بتسطيب البرنامج ليس بالامر الصعب بل سهل جدا وحتى لا يطول الشرح اذا واجهتك مشكلة فى تسطيب البرنامج يمكن كتابة وصور المشكله او البحث فى اليوتيوب وهتلاقى الحل المناسب (لكن عموما كل ال هتعمله اوافق والتالى التالى شكرا) بعد تنصيب البرنامج وهذه واجهته ويجب يكونو هكذا هنضغط على مفتاح Explorer او نذهب الى المسار هذا C:\xampp او حسب المكان الذى سطبت البرنامج فيه هندخل على المجلد htdocs وهنا هننسخ مشروعنا ويفضل متلعبش فى الملفات التى داخل المجلد htdocs غير لو انت فاهم بتعمل ايه نرجع لموضوعنا هننسخ الملف ال اسمه LAB وهنضعه فى المجلد htdocs هنفتح المتصفح وندخل على الرابط التالى http://localhost/phpmyadmin/ وهنبدأ بانشاء قاعدة بيانات جديده وهنسميها db_lab بعدها هندخل على القاعدة التى تم انشاءها وهنعمل عمليت استيراد هنضغط على استعراض وهنروح للمسار C:\xampp\htdocs\LAB هنلاقى فى ملف نفس اسم قاعدة البيانات وبعدها هننزل تحت وهنضغط على import وبهذا نكون قد انتهينا من رفع القاعدة نذهب الى هذا الرابط ونتحقق ان كل شئ تمام http://localhost/lab/ لو ظهر لك هذا الشاشة يبقي امورك فى التمام والحمد لله اذا لا بيكون فى خطأ حصل نبدأ نسطب برنامج Connector/ODBC MYSQL (( لا يحتاج الى شرح الامر بسيط وسهل وايضا حتى لا يطول الموضوع )) من هنا هنحتاج الى تركيز الامور بسيطه لكن لازم تتعمل صح هنروح للكنترول بنل لو انت شغال على وندوز 11 لو انت شغال على وندوز 10 هنا هتختار واحد منهم حسب اصدار الاوفيس عندك 32بت ولا 64 بتحميل انا هنا اصدار 64 بت هنكتب الاعدادات كما فى الصورة بالظبط لو انت حاطط كلمة سر لل phpmyadmin هتحطها وتضغط اوك بعد ما تختار القاعده الخاصه بك وبكده نكون انتهينا من هذا الجذء نبدأ تثبيت برنامج ActiveX WebBrowser control (antview) وده ال هيكون مسؤول عن استعراض صفحات الويب داخل الاكسيس وهي اداة ممتاذه عيبه تقريبا حسب الموقع انها مش مجانيه لو فى اى احد عنده طريقة نستخدم خاصية webview2 هي موجوده فى اوفيس 365 تقريبا وحسب ما سمعت انها بتنزل متضمنه لكن فى الاصدارات ال معانا مش موجوده او اى اداة اخري تكون مجانيه 100% يبقي تمام تثبيت البرنامج لا يحتاج شرح ^_^ نرجع لملف التطبيق الاكسيس ^_^ ونفتح البرنامج عادي بعد ما تم تثبيت كل الادوات السابق ذكرها وبرنامج الاكسيس هتلاقيه فى مجلد اسمه APP ممكن تنقله لاى مكان عادي وللعلم تم اضافة مكتبة واكود QR Code اخذتها من موضوع استاذى الاستاذ @ابو جودي فى موضوع الفاتورة الالكترونية 🤲 ربنا يبارك فيه وفى جميع اساتذتى هنا 🤲 نفتح ملف الاكسيس ونتأكد ان جميع المكتبات تعمل وليس هناك اى مكتبه مفقوده نركز على الصوره التالية هنتحقق من التالى ان الجداول متصله والمطلوب انك تفتح اى جدول للتأكد انه يعمل الاتصال جيدا هنفتح النماذج اول نموذج معانا FrmGenerator_User هنا انت لو عاوز تعمل اسم مستخدم وكلمة مرور ال هيدخل بيها المريض عندك كما هو موضح من الصورة حلين اما الاكسيس يعمل اسم مستخدم وكلمة سر عشوائية (1) او انت تعمل للمريض اسم مستخدم وكلمة سر يديوية (2) بعد ما تضيف حساب المريض هيكون هنا عندك القدرة على اضافة التقارير للمريض تابع الصور التالية يمكنك تحديد اكثر من ملف هنا فى الكود يسمح لك باستعراض ملفات الصور وال pdf بعد رفعها لو هناك اى ملاحظات تريد ان تسجلها يمكن هذا هتكتب الملاحظه وتعمل حفظ 😁 التالى لو انت عاوز تحول كلمة سر الى كود هاش هذا لو فرضا انك عاوز تغير كلمة السر لحساب ما وللعلم التشفير فى نظام ال PHP تشفير بالهاش هو تشفير فى اتجاه واحد يعنى يمكن عمل مطابقة لكلمة السر مع الهاش لكن متقدرش تحول الهاش الى كلمة سر طبعا ده علشان الحماية وده سياسة التشفير فى PHP والله اعلم او لو عاوز تتحقق من كلمة السر (يعني معاك كلمة السر والهاش وعاوز تتحقق انهم مطابقين ) هتضغط على التحقق وهو هيتحققلك بعد ما تم اضافة حساب للمريض عن طريق نموذج انشاء الحسابات وتم رفع الملفات للمريض هنروح على نموذج انشاء ال QR Code هنختار اسم حساب المريض من القائمة (قائمة المرضي) ونضغط على تصدير رمز ال QR اعتقد اني شرحت كل الامور واذا كان هناك اى مشكلة اقدر احلها لا تتردد فى الاستفسار وهتلاقى الجميع هنا بيسعدك بعض الملاحظات الواجب التنبيه لها يجب ان تغير عنوان الموقع اما للدومين اذا كان لديك دومين مع تعديل مسار البرنامج اذا لزم الام او كتابة عنوان الكمبيوتر الخاص بك اذا كنت تريد التجربه علشان لما تقراء كود QR يدخلك على الصفحه بطريقة صحيحة طريقة التعديل :- هتروح على كود نموذج انشاء كود QR وتعدل على العنوان بدل 127.0.0.1 وكل عام وانتم بخير وختاما نسألكم الدعاء لوالدتي الله يرحمها والشفاء لوالدي ربنا يبارك فى صحته ولا تنسونا من صالح دعواتكم الطيبة

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