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

قصدك علامة الاستفهام اللي في النافذة تحت نافذة الكود ، صح 🙂 معناها قم بتنفيذ الامر/المعادلة التي تلي علامة الاستفهام ، وهي عملية يدوية وليست برمجية ، اي لا يمكن حفظها كجزء من الكود ، مثلا : اذا اردت نتيجة ضرب 12 * 987456 ، فإذا كتبناها كما هي ، فلن يفهم الاكسس المقصود من الامر ، وتحصل على رسالة خطأ : . بينما لما نسبق هذه المعادلة بعلامة استفهام ، نحصل على النتيجة: . واما في مشاركتي السابقة ، فقمت بتنفيذ/تشغيل الدالة Save_Tashkeela ، بدل ان اعمل لها كود او زر خاص لتشغيلها : جعفر

اعرض الملف مؤشر تقدم العمل بتنسيق معين طلب مني زميل مؤشر لتقدم العمل بحسب التنسيق الموضح فى الصورة و قد اعددته باستخدام عدد 2 رسم بياني متداخل لكل حالة و المطلوب للاستخدام هو تعبئة نسبة تقدم العمل الحالي و المستهدف فقط كما هو فى الخلايا الملونة باللون الأصفر و اضطررت لإعداد أكثر من شكل حيث يختلف تنسيق الألوان بحسب حالة تقدم العمل ، وهو يعطي مدلولا خاطئا فى حال وجود حالة تقدم عمل مغايرة لما هو مبين تحت كل رسم. فأول شكلان يناسبان حالات عدم تحقيق المستهدف و الثالث مخصص لحالة تجاوز المستهدف اي عندما يكون الفعلي اكبر من المستهدف و هو يعطي مدلولا خاطئا في حالة عدم تحقيق المستهدف كما في الرسم التوضيحي. اضفت الحماية للشيت فقط كل لا تتأثر المعادلات و محاذاة الشكل مع الاستخدام ، و من اراد فك الحماية فكلمة السر لحماية الشيت هي عنوان الموقع www.officena.net و لكي تري المعادلات الغير ظاهرة غير لون الخط فى الخلايا في العمود A,B للصفوف 7,10,11 هذه هي النسخة الأولية ، فى انتظار تحسيناتكم و اضافاتكم صاحب الملف محمد طاهر تمت الاضافه 21 فبر, 2021 الاقسام قسم الإكسيل

السلام عليكم ورحمة الله وبركاته جزاكم الله خيراً أستاذنا الكريم @محمد طاهر عمل رائع حقاً ... تقبل تحياتي العطرة.☺️

Try This File Option Explicit Sub Regex_position(RG As Range, ByVal My_ExP As String) Dim rex As Object Dim Array_Pos() As Integer Dim Array_Mot() As String Dim Cnt% Dim My_Match, Sing_Match Dim K% Set rex = CreateObject("Vbscript.Regexp") With rex .Pattern = My_ExP: .ignorecase = True: .Global = True End With If rex.test(RG) Then K = RG.Row Set My_Match = rex.Execute(RG) Cnt = 0 For Each Sing_Match In My_Match ReDim Preserve Array_Pos(Cnt) ReDim Preserve Array_Mot(Cnt) Array_Pos(Cnt) = Val(Sing_Match.firstindex + 1) Array_Mot(Cnt) = Sing_Match Cnt = Cnt + 1 Next For Cnt = LBound(Array_Pos) To UBound(Array_Pos) With RG.Characters(Array_Pos(Cnt), Len(Array_Mot(Cnt))).Font .ColorIndex = Sheets("Formula"). _ Range("K1").Interior.ColorIndex .Size = 18: .Bold = True Sheets("Formula").Cells(K, "G") _ .Offset(, Cnt) = Array_Mot(Cnt) End With Next End If End Sub '++++++++++++++++++++++++++++++++++++ Sub Colorize_Please() reset_me Dim st, i%, lr lr = Sheets("Formula").Cells(Rows.Count, 5).End(3).Row st = "[A-Za-z]\d{2}" For i = 3 To lr Call Regex_position(Sheets("Formula").Range("E" & i), st) Next Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++ Sub reset_me() Dim x With Sheets("Formula") x = .Cells(Rows.Count, 5).End(3).Row .Range("G3:N" & x).ClearContents With .Range("E3:E" & x).Font .ColorIndex = 1 .Bold = True: .Size = 14 End With End With End Sub osama.xlsm

كشف بأسماء العاملين بالوحدة.xlsx السلام عليكم إخوانى أريد المساعدة فى عمل بحث داخل القائمة المنسدلة الموجودة فى الملف المرفق ...... بحيث يكون البحث بأول حرف من الأسم أو بأول كلمة من الأسم

Dim Fso dim MyPath set fso=createObject("Scripting.fileSystemObject") Mypath=fso.GetAbsolutePathName(".") With Createobject("Access.Application") .AutomationSecurity = 1 .opencurrentdatabase mypath & "\هناء اسم برنامجك", , "هناء كلمه السر" .usercontrol=True End with او اذا كان بدون كلمه سر هكذا Dim Fso dim MyPath set fso=createObject("Scripting.fileSystemObject") Mypath=fso.GetAbsolutePathName(".") With Createobject("Access.Application") .AutomationSecurity = 1 .opencurrentdatabase mypath & "\هناء اسم برنامجك" .usercontrol=True End with

الف شكر بارك الله فيكم هذا هوا المطلوب شكرا لك

طبقت لك على شهادة التكوين فقط وكنت آمل ان تكمل باقي الشهادات على نفس النمط تقريبا على كل جال اليك الملف فيه طلبك ان شاء الله برنامج انجاز الشهادات - اكواد الترحيل والتنقل بين النماذج (11).xlsm

ربنا يبارك فيك تمام كده انا متشكر جدا جدا على المجهود المبذل من سيادتكم عاجز على الشكر

تم معالجة الأمر الخلايا الحمراء في الغامود D يجب ان تكون فارغة ( لأن الماكرو يتعامل مغ الخلايا غير الفارغة في هذا العامود D فقط ) Option Explicit Sub Salim_test() Dim i%, Ro% Dim arr(), Ara As Range Dim Sh As Worksheet Dim dic As Object Dim R_D As Range Set Sh = Sheets("Sheet1") Ro = Sh.Cells(Rows.Count, 3).End(3).Row Set R_D = Sh.Range("D1:D" & Ro).SpecialCells(2, 23) Sh.Range("J2").Resize(Ro, 4).ClearContents arr = Array("Item NO", "Pack Qty", "TOTAL") Set dic = CreateObject("scripting.dictionary") For Each Ara In R_D.Areas For i = 1 To Ara.Rows.Count dic(Ara.Cells(i).Offset(, 2).Value) = _ dic(Ara.Cells(i).Offset(, 2).Value) _ + Val(Ara.Cells(i).Offset(, 3)) Next i With Ara.Cells(1).Offset(-1, 7) .Resize(, 3) = arr .Offset(1, 2) = WorksheetFunction.Sum(dic.items) .Offset(1).Resize(dic.Count, 2) = _ Application.Transpose(Array(dic.keys, dic.items)) .Offset(1, -1).Resize(dic.Count).Value = _ Evaluate("row(1:" & dic.Count & ")") End With dic.RemoveAll Next Ara Set Ara = Nothing: Set Sh = Nothing Set dic = Nothing: Set R_D = Nothing Erase arr End Sub TASALSUL.xlsm

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

احتصار بسيط للكود المقدم من الاستاذ محي الدين (عسى ان يكون المطلوب) Option Explicit Sub Salim_test() Dim a As Variant, i Dim ar, arr(), x Dim Sh As Worksheet Dim dic As Object x = 1 Set Sh = Sheets("Sheet1") Sh.Range("J1").Resize(10000, 4).ClearContents arr = Array("Item NO", "Pack Qty", "TOTAL") Set dic = CreateObject("scripting.dictionary") For Each ar In Sh.Columns("c:c").SpecialCells(2).Areas a = ar.Offset(1, 3).Resize(ar.Count - 1, 2) For i = 1 To UBound(a) dic(a(i, 1)) = dic(a(i, 1)) + Val(a(i, 2)) Next With Sh.Cells(x, 11) .Resize(, 3) = arr .Offset(1, 2) = WorksheetFunction.Sum(dic.items) .Offset(1).Resize(dic.Count, 2) = _ Application.Transpose(Array(dic.keys, dic.items)) .Offset(1, -1).Resize(dic.Count).Value = _ Evaluate("row(1:" & dic.Count & ")") End With x = x + UBound(a) + 2 dic.RemoveAll Next End Sub nany.xlsm

بارك الله فيك استاذ محي كود ممتاز nany4mg لا يوجد مشكلة كانت حاجة بسيطة وكان يجب عليها إكتشافها بنفسك وهى .... عليك بإستبدال هذا السطر بالكود , بطريق الخطأ من الأستاذ محي تم كتابة i مرتين كما ترى وهذا المتغير لم يكن متعرف بالكود For ii = 1 To IIf(.Count = 1, 1, .Count): Cells(x + 1, 11).Offset(ii - 1, -1) = ii: Next على ان يكون هكذا For i = 1 To IIf(.Count = 1, 1, .Count): Cells(x + 1, 11).Offset(i - 1, -1) = i: Next وبكده نكون وصلنا لكل طلباتك ويجب غلق المشاركة

السلام عليكم 🙂 ولو اني تأخرت عن الركب ، ولكن قد تكون مشاركتي مفيدة 🙂 المشكلة الموجودة في الكلمات العربية ، وفي بعض انواع الخط الخاصة (مثل خط القرآن الكريم) ، هو اننا لا نعرف ما هي التشكيلات الموجودة ، ولا رقمها ، وبمل اننا نتعامل مع اللغة العربية ، فللحصول على رقم الحرف/التشكيلة ان نستخدم AscW و ChrW (رجاء ملاحظة وجود W) ، عليه ، عملت هذه الدالة لإستخراج جميع الحروف/التشكيلات الموجودة في حقل nass في الجداول b4 و b5 و b6 ، وحفظها في جدول خاص بها tbl_Tashkeela ، في حقل Tashkeela (لا يقبل التكرار) 🙂 هذه هي الدالة: Function Save_Tashkeela() On Error GoTo err_Save_Tashkeela Dim rstTashkeela As DAO.Recordset Dim rstTables As DAO.Recordset Dim i As Integer, j As Integer Set rstTashkeela = CurrentDb.OpenRecordset("Select * From tbl_Tashkeela") For i = 4 To 6 Set rstTables = CurrentDb.OpenRecordset("Select nass From b" & i) Do Until rstTables.EOF For j = 1 To Len(rstTables!nass) rstTashkeela.AddNew rstTashkeela!Tashkeela = Mid(rstTables!nass, j, 1) rstTashkeela!Tashkeela_ChrW = AscW(Mid(rstTables!nass, j, 1)) rstTashkeela.Update Next j rstTables.MoveNext Loop Next i Exit_Save_Tashkeela: rstTables.Close: Set rstTables = Nothing rstTashkeela.Close: Set rstTashkeela = Nothing MsgBox "Done" Exit Function err_Save_Tashkeela: If Err.Number = 3022 Then 'duplicate found Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function . ولأننا سنستخدم هذه الدالة مرة واحدة (او حنى عدة مرات) ، فالاسهل لي ان اناديها من الكود هكذا (طبعا يمكن مناداتها من اي مكان (ولكن ليس من الاستعلام ، فمناداتها مرة واحد تكفي لتغطية جميع حروف الجداول ، بينما الاستعلام سياديها بعدد السجلات ، وهذا مضيعة للوقت ولا فائدة منه) ، ورجاء ملاحظة ان علامة الاستفهام هي باللغة الانجليزية 🙂 . ونتيجة الجدول: جعفر 1341.ارشيف2.mdb.zip

تــــم تعديل رفع الملف تسلسل.xlsm

اضف هذا المعيار في مصدر النموذج الفرعي Like "*" & [forms]![snawaqs_3]![asd1] & "*" وانظر الى التغير في كود حدث خانة الاختيار exam2.rar

المعادلة كما في الصورة الملف مرفق Ala3.xlsx

اتفضل

السلام عليكم و رحمة الله و بركاته من بعد اذن أستاذي صالح حمادي هل هذا ما تقصده ؟ قاعدة البيانات الشهادة المدرسية ومحضر التنصيب1.accdb

أولاً المعادلات الصحيحة دون ظهور عدد كبير من الأرقام بعد الغاصلة (كيف يجب ان تكون) في الصورة ثانياً لم تفهم ما تريد بالضيط (شروط النجاج في كل مادة ام النحاج في كل المواد) Complete.xlsx

مشكور أخ محمد على المساعدة. بميزان حسناتك ان شاء الله

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

نعم لاحظت هذا 🙂 ومو سهل ترجمة لغة الى لغة اخرى 😬 جعفر

في البداية جربت الطريقة التي شرحتها و كانت دائما النتيجة بالجنيه، شوية تحايل بواسطة أداة مرفوعة في المنتدى Converter Arabic and Unicode تعرفت على صيغة Unicode للجنيه بحثت عنها في و عوضتها بالدينار الجزائري في السطرين التاليين Resultat = Resultat & T2 & " " + ChrW(1583) + ChrW(1610) + ChrW(1606) + ChrW(1575) + ChrW(1585) + ChrW(32) + ChrW(1580) & ChrW(1586) + ChrW(1575) + ChrW(1585) + ChrW(1610) Else If Resultat <> "" Then Resultat = Resultat & " " + ChrW(1583) + ChrW(1610) + ChrW(1606) + ChrW(1575) + ChrW(1585) + ChrW(32) + ChrW(1580) & ChrW(1586) + ChrW(1575) + ChrW(1585) + ChrW(1610) هكذا تم الوصول الى النتيجة.

اعتذر عن الخطأ ، وتم تعديل المرفق في المشاركة السابقة 🙂 هذا تعديل على برنامج اخي @biskra والذي اخذ الكود من مرفق اخونا @أبو عبدالله الحلوانى ، يعني عمل جماعي 🙂 . والنتيجة . جعفر 1337.1.convert nacer.accdb.zip

تفضل هذه محاولة convert nacer.rar

وعليكم السلام ورحمة الله وبركاته استبدل الكود بهذا Private Sub CommandButton10_Click() Sheets("شهادة تكوين").Select Cells(16, 2).Value = TextBox1.Value Cells(15, 2).Value = TextBox2.Value Cells(15, 6).Value = TextBox3.Value Cells(17, 5).Value = TextBox4.Value Cells(18, 3).Value = TextBox5.Value Cells(19, 2).Value = TextBox6.Value Cells(19, 5).Value = TextBox7.Value Cells(20, 2).Value = TextBox8.Value Cells(20, 7).Value = TextBox12.Value End Sub استبدل UserForm1.Show Unload Me بــ Unload Me UserForm1.Show تفس الطلب الاول برنامج انجاز الشهادات - اكواد الترحيل والتنقل بين النماذج.xlsm

ربما؟ تلوين الكلمات.xlsm

يبدو ان المشكله من الكودات بداخل الملف لانني لم استطيع الدخول اللى document inspector سارفع لك الكلف هل يمكن ان تتاكد لي ان كانت من الكودات ام لا اليوزر شيكات .... كلمه المرور 12345 باسورد محرر الاكواد 2020 وشكرا شيكات.xlsm

وعليكم السلام تفضل: برنامج جاهز: http://www.peterssoftware.com/isd.htm وكود من https://www.experts-exchange.com/questions/28397475/Shutdown-Access-Database-After-Certain-Idle-Time.html Private Sub Form_Load() ' start the count down in 3 minutes (60 x 3 = 180) Me.Tag = 180 ' interval is every second Me.TimerInterval = 1000 End Sub Private Sub Form_Timer() On Error Resume Next '********************************** ' Bail out when count down is zero '********************************** Me.Tag = Val(Me.Tag) - (Me.TimerInterval / 1000) Me.Caption = "Form will exit in " & Me.Tag & " seconds" If Val(Me.Tag) <= 0 Then DoCmd.Quit End If End Sub . جعفر

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته،،، تحياتى الى الجميع هذه دعوة عامة للجميع لمن يمتلك ملف او مثال غريب وعجيب او نادر التداول او فكرة جديدة او امكانية من امكانيات الاكسل غير المطروقة ان يشترك معنا فى هذة المشاركة تحت اسم : غرائب وعجائب الاكسل وابدأ هذة المشاركة بملف اعجبى كثير يوضح بعض الامكانيات الغير شائعه بكثرة فى مجتمنا العربى فهو مثال عن الصوت والصورة او الرسوم المتحركة لنرى معا الملف . ارجو الدعاء لى . والسلام عليكم ورحمة الله وبركاته omar.rar