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

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

جرب هذا الكود (لتغيير عدد كلمات السر استبدل في الكود الرقم 19 الى اي رقم تريده) Option Explicit Sub My_Paws() Dim col As Object Dim i%, m, x, Bol, s, k% Const How_many_Pass = 19 Set col = New Collection For i = 64 To 90: col.Add Chr(i): Next For i = 97 To 122: col.Add Chr(i): Next For i = 0 To 9: col.Add i: Next col.Add "*" m = 2 x = col.Count For i = 1 To How_many_Pass For k = 1 To 12 Bol = Int(Rnd() * (x - 1)) + 1 s = s & col(Bol) Next k Cells(m, "G") = s m = m + 1: s = "" Next End Sub الملف مرفق alexandrien.xlsm

يمكن استعمال معادلة واحدة في الخلية B6 وسحبها يميناُ ( 4 أعمدة) ونزولاُ (20صف) =IFERROR(INDEX(INDIRECT($B$4),$A6,COLUMNS($A$1:A1)),"")

هذا القالب تختلف عن القالب الاساسي الذي تم العمل عليه ..... انظر اذا كل ماهو عليك هو تعديل هذا السطر لديك لاحظ بارك الله فيك موقع لصق البيانات كان C5 objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS الاستبدال يكون بهذا الشكل ولاحظ موقع لصق البيانات اصبح حسب ملفك الجديد C8 objWorkbook.Sheets(SHEET%).range("c8").CopyFromRecordset RS_STUDENTS فقط هذا كل شيئ .... ملاحظة يجب ان تكون جميع ملفات الاكسل ( احياء - فيزياء - رياضيات وغيرها بنفس تصميم ملف الرياضيات الجديد اقصد بذلك موقع لصق البيانات اي C8 ارجو اكون وفقت في الشرح !!!

المرفق السابق به خطأ.. أعتذر! Active Teacher.zip

وعليكم السلام-بعد اذن الأستاذ خيماوى ولإثراء الحل يمكنك ايضاً استخدام هذا الكود أو يمكن أيضاً بإستخدام المعادلات وهذه المعادلة للإسم =IFERROR(INDEX(A:A,AGGREGATE(15,6,ROW($1:$900)/(LEN($B$1:$B$900)-LEN(SUBSTITUTE($B$1:$B$900,"-",""))+1>=COLUMN($A:$J)),ROW(A1))),"") أما معادلة الكود فتكون كالتالى =IF(H2="","",TRIM(MID(SUBSTITUTE("-"&VLOOKUP(H2,$A$1:$B$900,2,0),"-",REPT(" ",99)),COUNTIF(H$2:H2,H2)*99,99))) Sub Demo() Dim Ary As Variant, Nary As Variant, Sp As Variant Dim r As Long, nr As Long, i As Long Ary = Range("A1").CurrentRegion.Value2 ReDim Nary(1 To UBound(Ary) * 100, 1 To 2) For r = 1 To UBound(Ary) Sp = Split(Ary(r, 2), "-") For i = 0 To UBound(Sp) nr = nr + 1 Nary(nr, 1) = Ary(r, 1) Nary(nr, 2) = Sp(i) Next i Next r Range("E:F").EntireColumn.Value = "" Range("E1").Resize(nr, 2).Value = Nary End Sub جدول بيانات الشراء1.xlsm

تفضل ... المأموريات - 001.accdb

استاذي الفاضل مجمد بارك الله فيك من خلال الاطلاع السريع على ما افدتني فيه شكله هو المطلوب غدا اجربه اعطيك الرد لك من اجمل تحيه مشكوررررررررررررر

الكود في حدث عند عدم وجو بيانات MsgBox "لا توجد بيانات لهذا التقرير. إلغاء التقرير...", vbMsgBoxRight, "لاتوجد بيانات" Cancel = -1 اضف حقل بالتقرير وسميه Cancel واجعل مصدره=1 تحياتي

ان شاء الله تجد ضالتك هنا التأكد من الاتصال بجهاز محدد على الشبكة المحلية - ( سلسلة تفكيك برنامج الارشفة الاليكترونية - 1) - قسم الأكسيس Access - أوفيسنا (officena.net)

فقط تختار الاسم ثم تضغط على الزر Run

ممكن تجرب المرفق ومبدئيا تم حساب كمية الطلب في الشيت بناء على إن المبيعات تكون أعلى من 50% وإن التالف يكون أقل من أو يساوي 8% غير كده مش هيطلب حاجة ( وده حسب مافهمت ) . وياريت حضرتك تحدد عمود يحسب نسبة المبيعات ونسبة التالف . لكن علشان تحدد كمية الطلب النهائية لازم تحسب شوية حجات أساسية ( مجرد إقتراح ) - فترة دوران المخزون ( ده علشان لو المبيعات تمت في وقت قليل ده معناه إن الصنف سريع الدوران و أقدر أجيب كمية أكبر لكن لو المبيعات تمت في فترة كبيرة ده معناه معدل دروان بطئ للصنف وبالتالي مش هطلب كمية كبيرة علشان المخزون عندي ما يطولش . مع الأخذ في الإعتبار وجود عرض على الصنف من عدمه وفترة العرض . - أقل كمية طلب ( وده علشان لو الصنف كان بطئ الدوران ساعتها يكون عندي أقل كمية ممكن أطلبها والمورد يقدر يوردهالي ) . - حد الطلب ( وده تمام حضرتك عامل حسابه لكن خلي بالك حد الطلب متغير مش سابت وماينفعش يكون بديل عن أقل كمية طلب إنما لو إنت عايز تثبته وفقاً لنظام شغلك مافيش مانع . - أكبر كمية للطلب ( وده علشان يكون عندي تحكم في أكبر كمية ممكن أطلبها والطلب مايتعداش الكمية دي ) .... الخ .PO.xlsx

شاهد هذا الفيديو https://www.youtube.com/watch?v=vk94OfXI9GM&ab_channel=TechnicalSupportOnline

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

تم تنزيل الملف مرة ثانية والتعديل على الكود 1- عند طباعة الفاتورة يتغير لونها و يدرج في العامود K تاريخ الطياعة 2- اذا اردت طباعتها مرة احرى تحصل على رسالة تفيد انه تم طباعتها مسيقاً والرسالة تعطيك حيار الطباعة مرة اخرى او لا 3- عندما تريد (عند نهاية الشهر مثلاً) اضغط الزر New Month لتمسح التواريخ و ترجع الألوان الى طبيعتها Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i%, Nb% Dim dic As Object Dim Mon_array Dim Itm Dim rg As Range Dim Answer As Byte '++++++++++++++++++ 'Other macro to Ptint One fatura Sub Fatura_Only_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then If Val(B.Range("H5")) <= 0 Or _ Val(B.Range("H5")) > dic.Count Then B.Range("H5") = 1 Else B.Range("H5") = Int(B.Range("H5")) End If Nb = Int(B.Range("H5")) - 1 B.Range("E6").Resize(9) = _ Application.Transpose(Split(dic.Items()(Nb), "*")) Set rg = S.Range("B1:B" & last).Find(B.Range("E7"), lookat:=1) If Not rg Is Nothing Then S.Cells(rg.Row, 1).Resize(, 9).Interior.ColorIndex = 35 End If If S.Cells(rg.Row, "K") Like "Printed On:*" Then Answer = MsgBox("هذه الفاتورة تمت طباعتها مسبقاُ" & Chr(10) & _ "هل تريد الطباعة مرة ثانية", 1048644) If Answer <> 6 Then GoTo End_me End If S.Cells(rg.Row, "K") = "Printed On:" & Date '========================== B.PrintPreview ' '======================== End If End_me: Set dic = Nothing End Sub الملف مرفق Bab Salam_Super.xlsm

الاستاذ العزيز سليم حاصبيا المبدع دائما وفقكم الله ورعاكم معادلة رائعة زادكم الله رزقا وعلما تحياتي ووافر احترامي

بارك الله فيك يا أخي الكريم وجزأك الله خير الجزاء وجعل الله ما قمت به في ميزان حسناتك على هذا هو المطلوب

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

اخ الكريم @Shivan Rekanyشكرا جزيل لك ماشاء الله عليك الله يزيدك علما ويبارك فيك

بارك الله فيك وعليك واكرمك الله تمام هو ده المطلوب

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

بارك الله فيك استاذنا الكريم دمتم دخرا للامة

السلام عليكم ورحمة الله وبركاته بعد اذن الاساتذة الكبار هذا حل بالدوال كما طلبت تحياتي لكم استخراج++ جدول (1).xlsx

نفترض ان حقل ( الادارة ) في الجدول المستخدمين يوزرس هو حقل اعطاء صلاحية لكل مستخدم , اذا كان مقابل هذا الحقل لأي مستخدم يساوي علامة صح راح يظهر له كل سجلات واي مستخدم ليس له علامة صح في ذلك الحقل فقط راح يظهر له سجلات تابعه , حينئذ راح نستخدم هذا الكود Private Sub Form_Open(Cancel As Integer) DoCmd.Maximize If DLookup("[الادارة]", "users", "[USERNAME]='" & Me.اسم__المستخدم & "'") = True Then Me.Form.RecordSource = "ادخال البيانات" Else Me.Form.RecordSource = "SELECT [ادخال البيانات].ID, [ادخال البيانات].[اسم الموقع], [ادخال البيانات].الرخصة, [ادخال البيانات].النشاط, [ادخال البيانات].المنطقة, [ادخال البيانات].[حالة الموقع], [ادخال البيانات].[رقم الهاتف الارضى], [ادخال البيانات].[رقم الهاتف المتحرك], [ادخال البيانات].[اسم مسؤول الموقع], [ادخال البيانات].الايميل, [ادخال البيانات].العدد, [ادخال البيانات].[اسم المستخدم] FROM [ادخال البيانات] WHERE ((([ادخال البيانات].[اسم المستخدم])=[Forms]![ادخال بيانات المواقع]![اسم المستخدم]));" End If End Sub واليك المرفق بعد تعديل mm (1).rar

شكر الله لك أخي الكريم @أبو إبراهيم الغامدي الأمور تسير إلى خير .. 🌹🌹

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

السلام عليكم استخدمت اكثر من برنامج ولكن لم يتم إرجاع إلا اثنان من الجداول أمأ بقية الكائنات فليس مهم استرجاعها كما تفضلت شكرا لك أخينا لتعاونك

السلام عليكم استاذ أكسس وبس هذه محاولة باضافة وحدات الحديد وان كانت موفقة فيمكن تطبيقها على بقية الوحدات وانا بخدمتك Root220.rar

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

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز جدول بيانات الشراء.xlsm

جرب هذا الكود Option Explicit Sub extract_Data() Dim Source_sheet As Worksheet Dim Target_sheet As Worksheet Dim Ism, R_to_copy As Range Dim Find_rg As Range Set Source_sheet = Sheets("sheet1") Set Target_sheet = Sheets("sheet2") If Target_sheet.Range("B4") = "" Then Target_sheet.Range("B4") = "خالد" End If Ism = Target_sheet.Range("B4") Set Find_rg = Source_sheet.Cells.Find(Ism, lookat:=1) If Not Find_rg Is Nothing Then Set R_to_copy = Find_rg.Offset(2).Resize(20, 4) Target_sheet.Range("B6").Resize(20, 4).Value = _ R_to_copy.Value End If End Sub الملف مرفق Khaled.xlsm

جيث انك لم ترفع ملف للمعاينة يمكن تجربة هذا الملف Date_function.xlsx

تم التوصل الى المطلوب وهذا هو التعديل .... Dim fldrname As String Dim fldrpath As String Dim LExcelOriginal As String Dim LExcelCopyOf As String Dim WHERE$ '.. اللاحقة $ تعني أن المتغير نصي Dim RS_SECTIONS As DAO.Recordset Dim RS_STUDENTS As DAO.Recordset Dim fso As Object Dim objExcel As Object Dim objWorkbook As Object '-- إنشاء مجلد للمقرر Set fso = CreateObject("scripting.filesystemobject") fldrname = Me.[text3] fldrpath = CurrentProject.Path & "\السجل الالكتروني\" & fldrname If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If '-- التأكد من توفر البيانات الأولية If Len(Me.text2) Then WHERE$ = " WHERE (Student.المادة='" & Me.text3 & "')AND (Student.الشعبة='" & Me.text2 & "')" ElseIf Len(Me.text3) Then WHERE$ = " WHERE (Student.المادة='" & Me.text3 & "')" Else MsgBox "بينات التصدير غير مكتملة" Exit Sub End If '-- إيجاد الشعب Set RS_SECTIONS = CurrentDb.OpenRecordset _ ("SELECT DISTINCT [الشعبة] FROM Student " & WHERE$ & "ORDER BY [الشعبة]") If RS_SECTIONS.RecordCount = 0 Then MsgBox "لا توجد بيانات لتصديرها" Exit Sub End If '-- نسخ قالب مصنف البيانات إلى مجلد المقرر LExcelOriginal = sXlsFile LExcelCopyOf = CurrentProject.Path & "\السجل الالكتروني\" & fldrname & "\" & Me.[text3] & "_.xlsm" Call FileCopy(LExcelOriginal, LExcelCopyOf) Set objExcel = CreateObject("Excel.Application") Set objWorkbook = objExcel.Workbooks.Open(LExcelCopyOf) '-- تدوير البيانات بناء على الشعب Dim SHEET% SHEET% = 2 Do Until RS_SECTIONS.EOF '-- إيجاد أسماء الطلاب بناء على الشعبة Set RS_STUDENTS = CurrentDb.OpenRecordset _ ("SELECT STUACDID,STUNAME FROM STUDENT WHERE [الشعبة]='" & RS_SECTIONS![الشعبة] & "' ORDER BY STUNAME") ' تعديل اسم صفحات الاكسل حسب اسماء الاستعلامات objWorkbook.Sheets(SHEET%).Name = RS_SECTIONS![الشعبة] '-- بيانات الترويسة objWorkbook.Sheets(SHEET%).range("B1").Value = _ "اسماء طلاب الصف " & "(" & Me.[text1] & ")" _ & " -- " & "(" & RS_SECTIONS![الشعبة] & ")" _ & " المادة " & "(" & Me.[text3] & ")" _ & " معلم المادة / " & "(" & Me.[text4] & ")" '-- بيانات الطلاب objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS SHEET% = SHEET% + 2 '-- الانتقال إلى الشعبة التالية RS_SECTIONS.MoveNext Loop '-- حفظ البيانات objExcel.DisplayAlerts = True objWorkbook.Close SaveChanges:=True '-- إغلاق المصادر objExcel.Quit Set objWorkbook = Nothing Set objExcel = Nothing Set RS_SECTIONS = Nothing Set RS_STUDENTS = Nothing ' VBA.Shell "Explorer.exe " & Chr(34) & LExcelCopyOf & Chr(34), vbNormalFocus"هذا السطر لفتح ملف الاكسل بعد التصدير" ' DoCmd.DeleteObject acTable, "temp" MsgBox "تم تصديرالبيانات بنجاح" تم اضافة هذه الشيفرية .... ' تعديل اسم صفحات الاكسل حسب اسماء الاستعلامات objWorkbook.Sheets(SHEET%).Name = RS_SECTIONS![الشعبة]

عظم الله اجركم وغفر الله لميتكم ربي يجعل مثواه الجنة

تم بحمد الله عمل المطلوب بواسطة المعادلات مرفق أتمنى لك التوفيق Items.xlsx

البقاء لله وحده

أهلا بالجميع.. الفكرة التي تناولتها حسب البيانات المتوفرة كاللآتي بما أن المقرر الدراسي يمكن أن يكون في أكثر من شعبة، والطلاب يتبعون للشعب فسوف يكون ترشيح البيانات كما يلي _ المقرر - شعبة1 - طلاب - شعبة 2- طلاب وهكذا حسب الشعب المدرجة لكل مقرر إليكم الشفرة بعد التعديل.. أرجو عدم اختيار الشعبة في هذه المرحلة لأنها بحاجة إلى المناقشة Public Sub barnaExcelFile(sXlsFile As String) Dim fldrname As String Dim fldrpath As String Dim LExcelOriginal As String Dim LExcelCopyOf As String Dim WHERE$ '.. اللاحقة $ تعني أن المتغير نصي Dim RS_SECTIONS As DAO.Recordset Dim RS_STUDENTS As DAO.Recordset Dim fso As Object Dim objExcel As Object Dim objWorkbook As Object '-- إنشاء مجلد للمقرر Set fso = CreateObject("scripting.filesystemobject") fldrname = Me.[text3] fldrpath = CurrentProject.Path & "\السجل الالكتروني\" & fldrname If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If '-- التأكد من توفر البيانات الأولية If Len(Me.text2) Then WHERE$ = " WHERE (Student.المادة='" & Me.text3 & "')AND (Student.الشعبة='" & Me.text2 & "')" ElseIf Len(Me.text3) Then WHERE$ = " WHERE (Student.المادة='" & Me.text3 & "')" Else MsgBox "بينات التصدير غير مكتملة" Exit Sub End If '-- إيجاد الشعب Set RS_SECTIONS = CurrentDb.OpenRecordset _ ("SELECT DISTINCT [الشعبة] FROM Student " & WHERE$ & "ORDER BY [الشعبة]") If RS_SECTIONS.RecordCount = 0 Then MsgBox "لا توجد بيانات لتصديرها" Exit Sub End If '-- نسخ قالب مصنف البيانات إلى مجلد المقرر LExcelOriginal = sXlsFile LExcelCopyOf = CurrentProject.Path & "\السجل الالكتروني\" & fldrname & "\" & Me.[text3] & "_.xlsm" Call FileCopy(LExcelOriginal, LExcelCopyOf) Set objExcel = CreateObject("Excel.Application") Set objWorkbook = objExcel.Workbooks.Open(LExcelCopyOf) '-- تدوير البيانات بناء على الشعب Dim SHEET% SHEET% = 2 Do Until RS_SECTIONS.EOF '-- إيجاد أسماء الطلاب بناء على الشعبة Set RS_STUDENTS = CurrentDb.OpenRecordset _ ("SELECT STUACDID,STUNAME FROM STUDENT WHERE [الشعبة]='" & RS_SECTIONS![الشعبة] & "' ORDER BY STUNAME") '-- بيانات الترويسة objWorkbook.Sheets(SHEET%).range("B1").Value = _ "اسماء طلاب الصف " & "(" & Me.[text1] & ")" _ & " -- " & "(" & RS_SECTIONS![الشعبة] & ")" _ & " المادة " & "(" & Me.[text3] & ")" _ & " معلم المادة / " & "(" & Me.[text4] & ")" '-- بيانات الطلاب objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS SHEET% = SHEET% + 2 '-- الانتقال إلى الشعبة التالية RS_SECTIONS.MoveNext Loop '-- حفظ البيانات objExcel.DisplayAlerts = True objWorkbook.Close SaveChanges:=True '-- إغلاق المصادر objExcel.Quit Set objWorkbook = Nothing Set objExcel = Nothing Set RS_SECTIONS = Nothing Set RS_STUDENTS = Nothing ' VBA.Shell "Explorer.exe " & Chr(34) & LExcelCopyOf & Chr(34), vbNormalFocus"هذا السطر لفتح ملف الاكسل بعد التصدير" ' DoCmd.DeleteObject acTable, "temp" MsgBox "تم تصديرالبيانات بنجاح" End Sub إليكم المرفق Active Teacher.zip

حقيقة لم استطع التعامل مع CopyFromRecordset ظهرت أخطاء لم استطع معالجتها ولعل صاحب الموضوع قد ذكر شىء من تلك الأخطاء ببداية الموضوع. لذا قمت بجلب البيانات باستخدام For من اجل ذلك سأنتظر رد أستاذنا @أبو إبراهيم الغامدي للتعلم والاستفادة أما عن طريقتي في حل الطلب الأستاذ @عفرنس وفقا للتوضيح الأخير. فكنت أنوي وضع هذا في بداية الكود If ShabaNo <= 4 Then shetNo = Val(ShabaNo * 2) Else Select Case ShabaNo Case 5 shetNo = 2 Case 6 shetNo = 4 Case 7 shetNo = 6 Case 8 shetNo = 8 End Select End If وأكرر سأنتظر رد أستاذنا @أبو إبراهيم الغامدي للتعلم والاستفادة

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

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

أحسنت البيان أ. محمد.. وفي نظري أن بقاء كل شعبة في ورقة مستقلة أرتب للبيانات وأسهل في التعامل!

أولا- باعتذر لتأخري بالرد فانا لا أزور الموقع الا بشكل متقطع هذه الأيام ثانيا- لنصل الي الحل الذي يرضيك أعد النظر فيما قال أستاذنا أبو ابراهيم. ما هي الآلية التي ستضيف بها بيانات الشعبتين في الشيت الواحد هل ستكون اسماء الشعبة الأولي أولا ثم بيانات الشعبة الثانية تحتها بنفس الأعمدة أم سيتم تغير موضع ادخال كل شعبة أوضح لنا هذه الجزئية لكي نستطيع المساعدة؟ كيف تريد أن يكون شكل بيانات الشعبتين داخل الشيت الواحد؟؟

ههههههه عامل تنسيق شرطي اي البلاوي دي بالمناسبة لما عملت زر مسح عندما تعمل تأشير على اكثر من مربع يمسح واحد فقط مو اكثر

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

تفضل أخي هل هي قاعدة البيانات كما هي shamal.rar

إليك الدالة المعرفة TimeToLettre الدالة تعمل إلى غاية "99:99:99" وتعمل للساعات فقط أو الدقائق فقط أو الثواني فقط Function TimeToLettre(Time As Variant) As String ' Created By Benkhalifa Djemoui ' Algeria: 05-12-2020 Dim MyHour As Variant Dim MyMinute As Variant Dim MM, HH, SS As String Dim H, M, S As Byte '=============================================================================================================================== MyHour = Array("", "ساعة", "ساعتان") '=============================================================================================================================== MyMinute = Array("صفر", "دقيقة", "دقيقتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع", _ "عشر", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر", _ "عشرون", "واحد و عشرون", "إثنان و عشرون", "ثلاثة و عشرون", "أربعة و عشرون", "خمسة و عشرون", "ستة و عشرون", _ "سبعة و عشرون", "ثمانية و عشرون", "تسعة عشرون", _ "ثلاثون", "واحد و ثلاثون", "إثنان و ثلاثون", "ثلاثة و ثلاثون", "أربعة و ثلاثون", _ "خمسة و ثلاثون", "ستة و ثلاثون", "سبعة و ثلاثون", "ثمانية و ثلاثون", "تسعة و ثلاثون", _ "أربعون", "واحد و أربعون", "إثنان و أربعون", "ثلاثة و أربعون", "أربعة و أربعون", "خمسة و أربعون", "ستة و أربعون", _ "سبعة و أربعون", "ثمانية و أربعون", "تسعة و أربعون", _ "خمسون", "واحد و خمسون", "إثنان و خمسون", "ثلاثة و خمسون", "أربعة و خمسون", _ "خمسة و خمسون", "ستة و خمسون", "سبعة و خمسون", "ثمانية و خمسون", "تسعة و خمسون", _ "ستون", "واحد و ستون", "إثنان و ستون", "ثلاثة و ستون", "أربعة و ستون", _ "خمسة و ستون", "ستة و ستون", "سبعة و ستون", "ثمانية و ستون", "تسعة و ستون", _ "سبعون", "واحد و سبعون", "إثنان و سبعون", "ثلاثة و سبعون", "أربعة و سبعون", _ "خمسة و سبعون", "ستة و سبعون", "سبعة و سبعون", "ثمانية و سبعون", "تسعة و سبعون", _ "ثمانون", "واحد و ثمانون", "إثنان و ثمانون", "ثلاثة و ثمانون", "أربعة و ثمانون", _ "خمسة و ثمانون", "ستة و ثمانون", "سبعة و ثمانون", "ثمانية و ثمانون", "تسعة و ثمانون", _ "تسعون", "واحد و تسعون", "إثنان و تسعون", "ثلاثة و تسعون", "أربعة و تسعون", _ "خمسة و تسعون", "ستة و تسعون", "سبعة و تسعون", "ثمانية و تسعون", "تسعة و تسعون") '=============================================================================================================================== Time = Split(Time, ":") H = Int(Time(0)) M = Int(Time(1)) S = Int(Time(2)) '=============================================================================================================================== If H = 0 Then GoTo Minute Select Case H Case 1 To 2: Select Case M: Case 0: HH = MyHour(H): Case Else: HH = MyHour(H) & " و ": End Select Case 3 To 10: Select Case M: Case 0: HH = MyMinute(H) & " ساعات ": Case Else: HH = MyMinute(H) & " ساعات و": End Select Case 11 To 99: Select Case M: Case 0: HH = MyMinute(H) & " ساعة ": Case Else: HH = MyMinute(H) & " ساعة و ": End Select End Select '=============================================================================================================================== Minute: If M = 0 Then GoTo Second If M <> 15 And M <> 30 Then Select Case M Case 1: Select Case S: Case 0: MM = MyMinute(M): Case Else: MM = MyMinute(M) & " و": End Select Case 2: Select Case S: Case 0: MM = MyMinute(M): Case Else: MM = MyMinute(M) & " و": End Select Case 3 To 10: Select Case S: Case 0: MM = MyMinute(M) & " دقائق ": Case Else: MM = MyMinute(M) & " دقائق و ": End Select Case 11 To 59: Select Case S: Case 0: MM = MyMinute(M) & " دقيقة ": Case Else: MM = MyMinute(M) & " دقيقة و ": End Select End Select '=============================================================================================================================== Else If H <> 0 Then Select Case M Case 15: Select Case S: Case 0: MM = " ربع ": Case Else: MM = " ربع و ": End Select Case 30: Select Case S: Case 0: MM = " نصف ": Case Else: MM = " نصف و ": End Select End Select Else Select Case M Case 15: Select Case S: Case 0: MM = " ربع ساعة ": Case Else: MM = " ربع و ": End Select Case 30: Select Case S: Case 0: MM = " نصف ساعة ": Case Else: MM = " نصف و ": End Select End Select End If End If '=============================================================================================================================== Second: If H <> 0 Or M <> 0 Then Select Case S Case 1: Select Case M: Case 0: SS = " و ثانية": Case Else: SS = " ثانية": End Select Case 2: Select Case M: Case 0: SS = " و ثانيتان": Case Else: SS = " ثانيتان": End Select Case 3 To 10: Select Case M: Case 0: SS = " و " & MyMinute(S) & " ثوان": Case Else: SS = MyMinute(S) & " ثوان": End Select Case 11 To 59: Select Case M: Case 0: SS = " و " & MyMinute(S) & " ثانية": Case Else: SS = MyMinute(S) & " ثانية": End Select End Select '=============================================================================================================================== Else Select Case S Case 1: SS = "ثانية" Case 2: SS = "ثانيتان" Case 3 To 10: SS = MyMinute(S) & " ثوان" Case 4 To 59: SS = MyMinute(S) & " ثانية" End Select End If '=============================================================================================================================== TimeToLettre = Trim(HH) & " " & Trim(MM) & " " & Trim(SS) '=============================================================================================================================== Erase MyHour, MyMinute End Function

جرب هذا اذا ووافنا بالنتائج تجربة.rar

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

اللهم اغفر لي ذنوبي كلها دقها وجلها...اللهم اغفر لي ما قدمت وما أخّرت وما أعلنت وما أسررت وما أنت أعلم به مني أنت المقدّم وأنت المؤخر وأنت على كل شيء قدير...اللهم اغفر لنا الذنوب التي تهتك العصم واغفر لنا الذنوب التي تجلب النقم

تفضل التعديل اخي الكريم مثال للرسائل عند عداد الوقت.zip