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

وعليكم السلام-لك ما طلبت بالتنسيقات الشرطية school02.xlsx

هذا الماكرو Private Sub Worksheet_Change(ByVal Target As Range) Dim My_rg As Range Dim Cret As Range Dim Rg_to As Range Const i = 2 Set My_rg = Range("B2:F13") Set Cret = Range("L3:L4") Set Rg_to = Range("J6:M6") Application.EnableEvents = False If Target.Address(0, 0) = "L4" _ And Target.Count = 1 Then My_rg.AdvancedFilter i, Cret, Rg_to End If Application.EnableEvents = True End Sub تم الشرح الماكرو بالتفصيل للتمكن من متابغتة مع امكانية احتصاره الى Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address(0, 0) = "L4" _ And Target.Count = 1 Then Range("B2:F13").AdvancedFilter 2, _ Range("L3:L4"), Range("J6:M6") End If Application.EnableEvents = True End Sub Bachiri.xlsm

تم تعديل الكود ليعطي حصص كل استاذ منفرداً جسب الأيام والصف والتوقيت Option Explicit Sub find_Prof() Dim A, i%, X% Dim First_Address$, Current_Address$ Dim F_rg As Range Dim Optional_rg As Range Dim Plage_E As Range, Plage_F As Range Dim Plage_G As Range, Plage_H As Range Dim Plage_I As Range, Plage_Match As Range Dim Ak As Worksheet, Pr As Worksheet Dim Clas$ Set Ak = Sheets("Akssam") Set Pr = Sheets("Prof") Pr.Range("E8:I84").ClearContents A = Array("محمود", "علي", "مصطفى", "عمر", "نورة", "عدي", "زيد") For i = 0 To UBound(A) Set Plage_Match = Pr.Range("D8:D18").Offset(i * 11) Set Plage_E = Pr.Range("E8:E18").Offset(i * 11) Set Plage_F = Pr.Range("F8:F18").Offset(i * 11) Set Plage_G = Pr.Range("G8:G18").Offset(i * 11) Set Plage_H = Pr.Range("H8:H18").Offset(i * 11) Set Plage_I = Pr.Range("I8:I18").Offset(i * 11) Set F_rg = Ak.Range("D8:M29").Find(A(i), lookat:=1) If Not F_rg Is Nothing Then First_Address = F_rg.Address Current_Address = First_Address Do Select Case F_rg.Row Case Is <= 18: Clas = "4م1 ف1" Case Is <= 19: Clas = "4م1 ف2" End Select Select Case F_rg.Column Case 5: Set Optional_rg = Plage_E Case 7: Set Optional_rg = Plage_F Case 9: Set Optional_rg = Plage_G Case 11: Set Optional_rg = Plage_H Case 13: Set Optional_rg = Plage_I End Select X = Application.Match(Ak.Cells(F_rg.Row, 3), Plage_Match, 0) Optional_rg.Cells(X) = F_rg & " / " & F_rg.Offset(, -1) _ & ": " & Clas Set F_rg = Ak.Range("D8:M29").FindNext(F_rg) Current_Address = F_rg.Address If First_Address = Current_Address Then Exit Do Loop End If 'for F_rg Next i End Sub الملف مرفق (عسى ان ينال الإعجاب) allaoua_Super.xlsm

وعليكم السلام-بعد اذن الأستاذ خيماوى ولإثراء الحل يمكنك ايضاً استخدام هذا الكود أو يمكن أيضاً بإستخدام المعادلات وهذه المعادلة للإسم =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

جرب هذا الكود 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

هذا تلقائي Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("$C$2:$H$40", "$K$2:$O$40")) Is Nothing _ And Target.Count = 1 Then Auto_sum End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++++ Sub Auto_sum() Dim H% With Sheets("Sheet2") H = .Cells(Rows.Count, "H").End(3).Row With .Range("k2:k" & H) .Formula = _ "=IF(C2="""","""",IF(AND(C2<=0,D2>=0,F2<=0,G2<=0,H2<=-15,M2<=-13),""Sell"",""""))" .Value = .Value End With With .Range("L2:L" & H) .Formula = _ "=IF(C2="""","""",IF(AND(F2<=0,G2<=0,H2<=-15,M2<=-8),""Wait"",""Close""))" .Value = .Value End With With .Range("N2:N" & H) .Formula = _ "=IF(C2="""","""",IF(AND(F2>=0,G2>=0,H2>=15,M2>=8),""Wait"",""Close""))" .Value = .Value End With End With End Sub الملف من جديد Emad_1.xlsm

تم بحمد الله عمل المطلوب يلزمك المراجعة بشكل دقيق تم تبسيط المعادلات والجداول: 1- ممكن الاستغناء عن الدالة index فقط بإعادة ترتيب الأعمدة (أضفت عمود جديد لذلك، ولم أحذف السابق) 2- ليفهم الاكسل مقصودك، قمت بتسمية الأيام بالأحرف الانجليزية (لأن اختيارك لليوم نص يوم بالانجليزي بينما تكتب الأيام بالعربي، فيلزم التوحيد) 3- أضفنا صف لتحديد عدد الساعات: مع العلم أنه يمكن الاستغناء عنه أو اخفاؤه ولكن باعتقادي أن وجوده مفيد للمراقبة 4- لغرض متابعة المعادلات وفهمها؛ فقد قمت بسحب الجداول وجعلها أسفل بعض، يمكنك سحبها وإعادتها للطريقة الطولية إن كان ذلك ضروريا أو تريد جلب موظف آخر أسفل هذا الموظف أسأل الله لك التوفيق حساب عدد ساعات العمل الاضافي.xlsx

وعليكم السلام توجد العديد من الامثلة بالموقع وهذه عبنه منها

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

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. إيميلات الطلبه.xlsx

وعليكم السلام-تفضل بهذه المعادلة تصل لطلبك =DATEDIF(K8,L8,"y")+DATEDIF(K9,L9,"y")&"years;"&DATEDIF(K8,L8,"ym")+DATEDIF(K9,L9,"ym")&"months;"&DATEDIF(K8,L8,"md")+DATEDIF(K9,L9,"md")&"days" معادلة1 DATEDIF.xlsx

تم انشاء ماكرو يقوم يهذا العمل (Print_Only _One) 1-اذا كانت الخلية H5 تحتوي على عدد اكبر من المطلوب ( يعني عدد المشتركين او عدد الأسماء) او عدد سالب او صفر او فارغة فأن الماكرو يسجلها 1 وبالتالي يستخرج أول مشترك 2- الماكرو بعمل على عدد المشتركين (مثلاً اذا كتبت 4 في الخلية H5 فإن الماكرو بستحرج رايع مشترك وليس الصف رفم 4) 3- الماكرو القديم ما زال يعمل في حال اردت طباعة الكل دفعة واحدة 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 '++++++++++++++++++ '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 S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone 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 '========================== B.PrintPreview ' '======================== End If Set dic = Nothing End Sub Bab Salam_New.xlsm

فورم شرح كيفية كتابة سورة الاخلاص على الاكسل الفيديو حمل الملف

أخي @أبو إبراهيم الغامدي والذي رفع السماء بلا عمد ما طرأ هذا الكلام على بالي .. غفر الله لي ولك .. * الأمر الثاني فالنسخة التي أعمل عليها فعلا ليست التي عملتها أنت .. وهذا ربما هو الذي أشكل علي .. * وإلى هنا سأتوقف .. * وأسأل الله أن يغفر لي ولك ..

لحل هذه الاشكالية وتمكين اختيار شعب بعينها يلزم تبديل الشفرة يالتالي 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% Do Until RS_SECTIONS.EOF SHEET% = Choose(CInt(RS_SECTIONS![الشعبة]), 2, 4, 6, 8, 2, 4, 6, 8) '-- إيجاد أسماء الطلاب بناء على الشعبة Set RS_STUDENTS = CurrentDb.OpenRecordset _ ("SELECT STUACDID,STUNAME FROM STUDENT " _ & "WHERE (Student.المادة='" & Me.text3 & "') AND (Student.الشعبة='" & 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 '-- الانتقال إلى الشعبة التالية 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

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

أعتذر عن هذا الخطأ.. أ. @Barna قام بالواجب

ابحث عن هذا الكود لديك واستبدله بهذا ... ("SELECT STUDENT.STUACDID, STUDENT.STUNAME FROM STUDENT WHERE (((STUDENT.المادة)='" & text3 & "') AND ((STUDENT.الشعبة)='" & RS_SECTIONS![الشعبة] & "')) ORDER BY STUDENT.STUNAME;")

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

الف مليون مبروك ومن تقدم الي تقدم ان شاء الله

جيث انك لم ترفع ملف للمعاينة يمكن تجربة هذا الملف 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![الشعبة]

امسح ما هو في المربعات الحمراء من الكود

الكود المطلوب تم ازالة الالوان الفاقعة لسهولة النظر الى الملف (بمكنك اعادنها) أو نسخ الكود الى ملفك Option Explicit Sub Auto_sum() Dim H% With Sheets("Sheet2") H = .Cells(Rows.Count, "H").End(3).Row .Range("k2:k" & H).Formula = _ "=IF(AND(C2<=0,D2>=0,F2<=0,G2<=0,H2<=-15,M2<=-13),""Sell"","""")" .Range("k2:k" & H).Value = _ .Range("k2:k" & H).Value .Range("L2:L" & H).Formula = _ "=IF(AND(F3<=0,G3<=0,H3<=-15,M3<=-8),""Wait"",""Close"")" .Range("L2:L" & H).Value = _ .Range("L2:L" & H).Value .Range("N2:N" & H).Formula = _ "=IF(AND(F2>=0,G2>=0,H2>=15,M2>=8),""Wait"",""Close"")" .Range("N2:N" & H).Value = _ .Range("N2:N" & H).Value End With End Sub الملف مرفق Emad.xlsm

وعليكم السلام 🙂 شو المطلوب؟ جعفر

تم حل الموضوع للأخ عبدالله قدور. الكود لمن يريده: Option Compare Database Private Type CHOOSECOLOR lStructSize As LongPtr hwndOwner As LongPtr hInstance As LongPtr rgbResult As LongPtr lpCustColors As String flags As LongPtr lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As String End Type Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _ "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As LongPtr Dim CustomColors() As Byte Private Sub cmdS_Click() Dim cc As CHOOSECOLOR Dim Custcolor(16) As LongPtr Dim lReturn As LongPtr cc.lStructSize = LenB(cc) cc.hwndOwner = Application.hWndAccessApp cc.hInstance = 0 cc.lpCustColors = StrConv(CustomColors, vbUnicode) cc.flags = 0 lReturn = ChooseColorAPI(cc) If lReturn <> 0 Then CustomColors = StrConv(cc.lpCustColors, vbFromUnicode) MsgBox cc.rgbResult Else MsgBox "User chose the Cancel Button" End If End Sub Private Sub Form_Load() ReDim CustomColors(0 To 16 * 4 - 1) As Byte Dim i As Integer For i = LBound(CustomColors) To UBound(CustomColors) CustomColors(i) = 0 Next i End Sub

بالخدمة استاذي العزيز والدعاء بالصحة والسلامة لك ولجميع الناس امين رب العالمين

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

السلام عليكم اخي الفاضل husamwahab لك كل التقدير والاحترام علي سرعة الاستجابة هذا هو المطلوب بالضبط وعندما يكتمل البرنامج سأضعه هدية للمنتدي في رأس السنة الميلادية ان شاء الله وكنا من الاحياء

دقيقة واحدة استاذ امير MyApp.rar اتفضل البرنامج بعد التعديل

جرب هذا الكود 1-دائماً وأبداً تسمية الشيتات باللغة الأجنبية لحسن عمل الكود ونسخه ولصقه والابتعاد قدر الامكان عن الخلايا المدمجة Option Explicit Sub find_Prof() Dim A, itm Dim Ad1$, Ad2$ Dim F_rg As Range Dim Find_what Dim Ak As Worksheet, Pr As Worksheet Dim Clas$ Dim col Set Ak = Sheets("Akssam") Set Pr = Sheets("Prof") Pr.Range("E8:I29").ClearContents A = Array("محمود", "علي", "عمر", "مصطفى") For Each itm In A Set F_rg = Ak.Range("D8:M29").Find(itm, lookat:=1) If Not F_rg Is Nothing Then Ad1 = F_rg.Address: Ad2 = Ad1 Do Select Case F_rg.Row Case Is <= 18: Clas = "4م1 ف1" Case Is <= 19: Clas = "4م1 ف2" End Select Select Case F_rg.Column Case 5: col = 5 Case 7: col = 6 Case 9: col = 7 Case 11: col = 8 Case 13: col = 9 End Select Pr.Cells(F_rg.Row, col) = F_rg & " / " & F_rg.Offset(, -1) _ & ": " & Clas Set F_rg = Ak.Range("D8:M29").FindNext(F_rg) Ad2 = F_rg.Address If Ad1 = Ad2 Then Exit Do Loop End If Next End Sub الملف مرفق allaoua.xlsm

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. إيميلات الطلبه.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

تم وضع الكود اللازم 1- الكود يعطي معاينة قبل الطياعة 2- لجعله يطبع مباشرة استبدل ما موجود في الكود بين علامات اليساوي "============" بــ B.PrintOut Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, Ro%, i% Dim dic As Object Dim Mon_array Dim Itm '++++++++++++++++++++++++++++++++ Sub Fatura_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35 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 For Each Itm In dic.items() B.Range("E6").Resize(9) = _ Application.Transpose(Split(Itm, "*")) '========================== B.PrintPreview '======================== Next End If Set dic = Nothing End Sub الملف مرفق Bab Salam.xlsm

تفضل أستاذ في المثال دالتان معرفتان الدالة الأولى لتفقيط الوقت الدالة الثانية لتفقيط مجموع الوقت دالة تفقيط الوقت.xls

إليك الدالة المعرفة 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

السلام عليكم ورحمة الله جرب هذا الكود Sub GetName() Dim ws As Worksheet, Arr As Variant Dim LR As Long, i As Long Dim j As Long, x As Long Application.ScreenUpdating = False Set ws = Sheets("ورقة2") LR = ws.Range("A" & Rows.Count).End(3).Row Arr = ws.Range("A13:AA" & LR).Value x = 3 Do While x <= 27 For i = 1 To UBound(Arr, 1) For j = 1 To UBound(Arr, 2) If ws.Cells(1, x) = Arr(i, j) Then ws.Cells(2, x) = Arr(i, 1) End If Next Next x = x + 1 Loop Application.ScreenUpdating = True End Sub

فورم اكسل استدعاء بيانات وصور العاملين الفيديو الصور الملف على الرابط التالى http://www.mediafire.com/file/r92gpfff79v1wgz/بيانات+وصور+الموظفين.rar

السلام عليكم ورحمة الله وبركاته فكرة بسيطة لترجمة الاسماء باللغة العربية الى اللغة الانجليزية ممكن تجربته names.xlsm

آسف نسيت المرفق تفضل db2.rar

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