كل الانشطه

الف شكر للأستاذ / أبو خليل على مجهودكم هذا هو المطلوب تماما .. فلكم جزيل الشكر

أخي جو الخطأ منك ، حيث في استعلامك يتم تحديث حقل مختلف في جدول مختلف عن الحقل الموجود في الاستعلام مصدر النموذج الفرعي انظر التعديل الصحيح :- DoCmd.RunSQL "UPDATE Tbl_Lab_All SET Tbl_Lab_All.External_lab = 'المختبر'" & _ " WHERE PCode = " & Me.ID & ";"

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

استاذى الفاضل كل مااريدة هو عند تحديد اى سجل من النموذج الفرعى يظهر رقم الكود الخاص بالسجل فى مريع نص I'd فى الرئيسى اريد تحديث هذا السجل فقط وليس كل السجلات كما بالصورة فى النموذج الرئيسى انا واقف علي سجل رقم ٤٠ ومن النموذج الفرعى حددت رقم ٣٨ ظهر رقم ٣٨ فى النموذج الرئيسي اريد تحديث هذا السجل فقط بإضافة بكلمة المختبر لحقلexternal_lab عند الضغط علي الزر الأحمر او بكلمة البرج عند الضغط علي الزر الأصفر اتمنى بكون طلبى واضح بالنسبة لاختلاف تنسيق التقرير لا توجد مشكلة اعمل علي هذا البرنامج من ٥ سنوات

السلام عليكم ورحمة الله وبركاته أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه. أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا. كما لا يفوتني أن أوجه التحية والتقدير لأخينا الحبيب، الأستاذ الفاضل algammal. تحياتي واحترامي لك أخي العزيز، وبعد إذن معلمنا، هذه محاولة متواضعة لتنفيذ طلب أخينا العزيز، حسب ما فهمته من سؤاله. أتمنى أن تقوم بتجربة الحل، وإذا كان هناك أي تعديل أو توضيح إضافي، فأنا على أتم الاستعداد . مع خالص التحية والتقدير لكما ولكل منابعى المنتدى، الكود Sub ترحيل_البيانات() Dim wsMain As Worksheet, wsNew As Worksheet Dim dict As Object, dataArray As Variant Dim i As Long, lastRow As Long, targetRow As Long Dim startTime As Double: startTime = Timer Dim sheetName As String With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayAlerts = False .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات..." End With On Error GoTo ErrorHandler Set wsMain = ThisWorkbook.Sheets("معاشات") Set dict = CreateObject("Scripting.Dictionary") lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub dataArray = wsMain.Range("A5:M" & lastRow).Value For i = 1 To UBound(dataArray, 1) sheetName = Trim(dataArray(i, 5)) If sheetName <> "" Then dict(sheetName) = Empty Next i Application.DisplayAlerts = False For Each wsNew In ThisWorkbook.Worksheets If Not wsNew Is wsMain Then If dict.exists(wsNew.Name) Then wsNew.Delete End If Next wsNew Application.DisplayAlerts = True Dim key As Variant, rowIndex As Long For Each key In dict.keys Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = key wsNew.DisplayRightToLeft = True wsMain.Range("A1:M4").Copy wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False wsMain.Rows("3:4").Copy wsNew.Rows("3:4").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False targetRow = 5 For rowIndex = 1 To UBound(dataArray, 1) If Trim(dataArray(rowIndex, 5)) = key Then wsMain.Range("A" & rowIndex + 4 & ":M" & rowIndex + 4).Copy wsNew.Range("A" & targetRow) targetRow = targetRow + 1 End If Next rowIndex For i = 1 To wsMain.UsedRange.Rows.Count If i <= wsNew.UsedRange.Rows.Count Then wsNew.Rows(i).RowHeight = wsMain.Rows(i).RowHeight End If Next i For i = 1 To 13 wsNew.Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth Next i Next key wsMain.Activate CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .StatusBar = False End With ' MsgBox "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume CleanUp End Sub الملف ترحيل البيانات من شيت إلى عدة شيتات مستقلة.xlsb

أخي جو ، اعذرني على مداخلتي ، ولكن الصورة غير واضحة ، وكأنها كانت مجرد رفع عتب أنك قمت بالتوضيح بشكل غير واضح !!! ثانياً ، PCode = 40 في الجدول Tbl_Lab_All ، يمثل السجل "هاجر عشرى على" على سبيل المثال . فكيف تريد تحديث القيمة لباقي السجلات , ولكن تبين لي أن الرابط فيما بينهم هو حقل التاريخ إن لم أكن مخطئاً ، صحيح ؟ وعليه فبعد تتبع تنسيق التاريخ في الجدول Tbl_Lab_Requests في الحقل Date_R ، كان التاريخ بالتنسيق "2025-01-12" بينما في النموذج في مربع النص DDate = 12,January,2025 ، أي أن التنسيق مختلف في حال قمنا بتحديد التاريخ كشرط للسجلات التي تتبع نفس التاريخ للتحديث . انظر ماذا تستطيع فعله لتلافي هذه المشكلة في تصميمك لمشروعك .

تفضل هذه احدى الحلول لاحظ ان الاستعلام الجدولي يجب ان يشتمل على 3 حقول فأكثر لذا اضفت حقل للجدول كمعرف للجنة احصاء2.rar

الف شكر لتعبكم ... ولكنى لم اوضح المقصود جيدا أريد ان يكون التقرير يشبه هذا اى تكون الاحصاءات متجاوة بجوار اسم اللجنة افقيا واللجنة اسمها يذكر مرة واحدة ولا يكرر احصاء2.accdb

أخي الكريم / Foksh السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا على المعلومة الجديدة بالنسبة لي أما بخصوص الكود التالي - والذي لكم الفضل في أن يظهر بهذا الشكل - والذي أعنيه فهو موجود في ورقة2 شيت ( معاشات) وبدايته هي: Sub CopyDataToWorksheets() Dim wsData As Worksheet Dim wsNew As Worksheet Dim cell As Range Dim lastRow As Long Dim i As Long Dim sheetNames As Object Set sheetNames = CreateObject("Scripting.Dictionary") ' تعيين الورقة التي تحتوي على البيانات (اسم الورقة هو "معاشات") Set wsData = ThisWorkbook.Sheets("معاشات") Application.ScreenUpdating = False ' تعطيل تحديث الشاشة لتسريع الأداء ' حساب آخر صف غير فارغ في العمود E lastRow = wsData.Cells(wsData.Rows.Count, "E").End(xlUp).Row ' تحويل البيانات في العمود E إلى أسماء الأوراق العمل ونسخ الصفوف المناسبة For Each cell In wsData.Range("E5:E" & lastRow) ' التحقق من صحة الأحرف في اسم الورقة العمل Dim sheetName As Variant sheetName = Trim(CStr(cell.Value)) ' التحقق من صحة اسم الورقة العمل المحدثة If sheetName <> "" Then ' إضافة اسم الورقة الجديدة إلى القاموس (دون تكرار) If Not sheetNames.exists(sheetName) Then sheetNames(sheetName) = 1 End If End If Next cell ' حذف الأوراق القديمة المطابقة وإنشاء أوراق جديدة For Each wsNew In ThisWorkbook.Sheets If Not wsNew Is wsData Then If sheetNames.exists(wsNew.Name) Then ' حذف الأوراق القديمة Application.DisplayAlerts = False wsNew.Delete Application.DisplayAlerts = True End If End If Next wsNew ' إنشاء الأوراق الجديدة ونسخ البيانات المطابقة For Each sheetName In sheetNames.keys If Not SheetExists(CStr(sheetName)) Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = CStr(sheetName) wsData.Rows(4).Copy Destination:=wsNew.Rows(4) i = 5 ' تبدأ من الصف الثاني Do Until IsEmpty(wsData.Cells(i, "E")) If wsData.Cells(i, "E").Value = CStr(sheetName) Then wsData.Rows(i).Copy Destination:=wsNew.Rows(wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row + 1) End If i = i + 1 Loop ' تعديل عرض الأعمدة في الورقة الجديدة وفقًا للعرض في الورقة الأصلية wsData.Columns.AutoFit wsNew.Columns.AutoFit End If Next sheetName Application.ScreenUpdating = True ' تمكين تحديث الشاشة مرة أخرى End Sub Function SheetExists(sheetName As String) As Boolean Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.Name = sheetName Then SheetExists = True Exit Function End If Next ws SheetExists = False End Function فقط أود أن ألفت الانتباه إلى أن الكود الموجود في (Module1) يعمل بكفاءة عالية ولا أريد التعديل عليه حيث أنه مرتبط بزر (ترحيل المحالين على المعاش) في شيت (DATA) إلى شيت (معاشات)؛ وما أريده أخي الكريم هو الكود المذكور عاليه والمرتبط بزر (ترحيل البيانات) الموجود في شيت (معاشات) مع الشيتات الناتجة عنه وهي: (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل)؛ ما أريده ألخصه فيما يلي: 1= أريد ظهور الخلايا (J3:B3) بنفس تنسيقها في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) وأن تظل ثابته لا تتأثر بترحيل البيانات في المرات القادمة حي أنها تختفي كلما قمت بترحيل البيانات. 2= أريد ارتفاع الصف (20.25) في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) بأكملها من أول صف لآخر صف. 3= أريد عرض الأعمدة من (B:A) فقط في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) مطابقة لعرض الأعمدة المذكورة في شيت (معاشات)؛ حيث أن عرض الأعمدة من (M:C) مضبوطة ولا تحتاج تعديل. ملحوظة: أما بخصوص الخط في الخلية (E3) شيت (معاشات) فقد تم حله بفضل الله. هذا والله الموفق والمستعان وجزاكم الله خير الجزاء؛ وأسعدكم في الدارين: الدنيا والاخرة وتقبلوا خالص احترامي وتقديري

استاذى الفاضل إليك قاعدة مصغرة للتعديل عليها JO_Lab.rar

حياكم الله محتاج كود يعمل على : 1. نوع الخروج (خروجية) 2. يرحل كل من لديه مدة الخروج اكثر من سبع ساعات - فاذا كانت 8 ساعة مدة الخروج ترحل سبع ساعات وتبقى ساعة واحدة مدور على الشهر الذي يلية وهكذا فاذا كن لديه 15 ساعة ترحل 14 ساعة وتبقى ساعة واحد اذ ان كل سبع ساعات تعتبر اجازة يوم واحد 3. كل البيانات المشمولة بالشروط اعلاه ترحل الى شيت اسمه مقبرة الخروجيات وتحذف من السجل 4 . والمتبقي يكتب مدور من الشهر السابق في عمود جديد أو اي فكرة ترونه مناسبة مشكورين - وأي شيء غير مفهوم ارجو اعلامي ترحيل الى شيت اخر لمن لديه سبع أو اكثر.xlsx

السبب أن الاستعلام يستخدم القيمة من النموذج الرئيسي ([Forms]![Laboratory]![id]) ، بينما السجلات التي تريد تحديثها موجودة في النموذج الفرعي المستمر ، أي أن هناك عدة سجلات بنفس PCode ، لكن التحديث يستهدف سجلًا واحداً فقط . ويجب أن تأخذ قيمة المفتاح (PCode) من السجل الحالي في النموذج الفرعي ، وليس من النموذج الرئيسي . لذا جرب هذا التعديل ، رغم انك تعلم جيداً ضرورة ارفاق ملف في معظم الطلبات والاستفسارات.. DoCmd.RunSQL "UPDATE Tbl_Lab_Requests SET R_External_lab = 'المختبر' " & _ "WHERE PCode = " & Forms!Frm_Main!Frm_Sub.Form!PCode & ";" فقط تأكد من اسم نموذج الفرعي والرئيسي اخي الكريم ..

DoCmd.RunSQL "UPDATE Tbl_Lab_Requests SET Tbl_Lab_Requests.R_External_lab = ""المختبر"" " & _ " WHERE (((Tbl_Lab_Requests.PCode)= [Forms]![Laboratory]![id]));" DoCmd.RunSQL "UPDATE Tbl_Lab_Requests SET Tbl_Lab_Requests.R_External_lab = ""المختبر"" " & _ " WHERE (((Tbl_Lab_Requests.PCode)= [Forms]![Laboratory]![id]));"

اهلا اخي الكريم 🤗 الأمر بسيط بإذن الله تعالى ، في المكان الذي تكتب فيه رسالتك او موضوعك أو ردك ، يوجد زر <> هذا الزر وظيفته لكتابة الأكواد التي تود مشاركتها معنا ، جربه وستجد الموضوع بتنسيق ونمط جميلين في ردودك لاحقاً.

اخي الكريم @jo_2010 ، ارفق الكود مكتوب وليس صورة اذا تكرمت .

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

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

نعم الاستعلام هو مصدر الفورم الفرعي والتقرير أيضا

اجعل الاستعلام الحاصل مصدرا لتقريرك احصاء.rar

وإياكم

ارجو المساعدة فى اريد عمل تقرير يظهر امام كل لجنة احصاء بعدد المعاونون الملاحظون رئيس اللجنة المراقب الأول .. ولكم الشكر احصاء.accdb

جزاك الله كل خير

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

السلام عليكم محتاج انقل البيانات من عمود 1 الي عمود 2 بدون الخلايا التي تحتوي علي صفر او فارغه مع النقل بالترتيب ويعمل بشكل اتوماتيكي اذا تغيرت البيانات في العمود 1 جزاكم الله عنا كل خير نقل البيانات من عمود لاخر.xlsx

ولا يهمك اخي الكريم ، خذ راحتك ، واليوم فعلاً انا خارج المنزل وبعيد عن الكمبيوتر الى صباح غد إن شاء الله 🤗😇