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

ارشيف2.mdb

مشاركة مع الاستاذ الفاضل .... يمكن استخدام هذا الفانك وتستدعيه في الاستعلام Public Function delTshkeel(tshkeel As String) Dim i As Integer Dim fld As String, wr As String, spa As String wr = "" fld = tshkeel i = 1 Do While i <= Len(fld) spa = Mid(fld, i, 1) If Asc(spa) = 240 Or Asc(spa) = 241 Or Asc(spa) = 242 Or Asc(spa) = 243 Or Asc(spa) = 244 Or Asc(spa) = 245 Or Asc(spa) = 246 Or Asc(spa) = 247 Or Asc(spa) = 248 Or Asc(spa) = 249 Or Asc(spa) = 250 Then Else wr = wr & spa End If i = i + 1 Loop delTshkeel = wr End Function وتسدعيه في الاستعلام هكذا .... expr1: delTshkeel([text1])

وعليكم السلام-بعد اذن الأستاذ سليم ولإثراء الموضوع ,تفضل تم عمل معادلة مصفوفة لطلبك (Ctrl+Shift+Enter) ... كما تم عمل قائمة منسدلة بالخلية B1 لتسهيل العمل لك لإختيار بدلاً من الكتابة لتقليل الأخطاء =IFERROR(INDEX(رئيسية!$B$2:$B$140,SMALL(IF(رئيسية!$C$2:$C$140=$B$1,ROW(A$2:A$140)-ROW(A$2)+1),ROWS($A$3:A3))),"") GOING1.xlsx

جرب هذا الملف Taner.xlsx

وعليكم السلام يمكنك استخدام هذه المعادلة-معادلة مصفوفة (Ctrl+Shift+Enter) IF(AND(A$19<>$A$1:$U$1,A$19<>$A$9:$U$9),"غير موجود",IFERROR(HLOOKUP(A$19,$A$1:$U$3,2,0),HLOOKUP(A$19,$A$9:$U$11,2,0))) دمج1.xlsx

السلام عليكم شكراً للقائمين على هذا المنتدى العملاق من مشرفين واعضاء لني تعلمت منهم الاكثير واتمنى لهم الموفقية والصحة الدائمة ان شاء الله تعالى. اخوتي انا اعرف ان في هذا المنتدى عمالقة التصميم والبرمجة وانا اعلم ان في هذا المنتدى افضل من هذا البرنامج ولكن لرد الجميل هذا المنتدى ارفع هذه نسخة من برنامج الصادر والوارد مفتوح المصدر برابط خارجي صممتة لصديق لي يعمل في شركة .... تحياتي لكم جميعاً.... https://up.top4top.net/downloadf-1058tvebj1-rar.html

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

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

عجزت ان اجد ما يوفيك من كلمات الشكر ولكن لم اعجز عن دعوة لك بظهر الغيب اسأل الله لك التوفيق والعفو والعافية والمعافية فية دينك وبدنك دمت سالماً ودمت بخير -------

انظر للمرفق لكن افحصة قبل فتحة ارشيف.mdb

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

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

هذا الماكرو يقوم بتجديد التكرار باللون الاصفر (العامودين الاول والثاني) Option Explicit 'Excel VBA find duplicates with the scripting dictionary Rem Created By salim hasbaya On 21/2/2021 Sub Find_Dupl() Dim D As Worksheet Dim ar As Variant, Curt_rg As Range Dim i As Long, Rg As Range Dim ro% Set D = Sheets("Data") Set Curt_rg = D.Range("B2").CurrentRegion ro = Curt_rg.Rows.Count If ro = 1 Then Exit Sub Set Curt_rg = Curt_rg.Offset(1).Resize(ro - 1) Curt_rg.Interior.ColorIndex = xlNone ar = D.Cells(2, 2).CurrentRegion.Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 2 To UBound(ar, 1) If Not .Exists(ar(i, 1) & "*" & ar(i, 2)) Then .Item(ar(i, 1) & "*" & ar(i, 2)) = Empty Else If Rg Is Nothing Then Set Rg = D.Cells(i, 2).Resize(, 2) Else Set Rg = Union(Rg, D.Cells(i, 2).Resize(, 2)) End If End If Next End With If Not Rg Is Nothing Then Rg.Interior.ColorIndex = 6 End If End Sub الملف مرفق Ksaa.xlsm

وجدت صعوبة في العثور على حركات التشكيل للكلمات، مجرد محاولة ممكن تفيدك في المطلوب، في الجدول هناك حقلان، واحد لن يتغير txt_name_test و هذا بغرض المقارنة فقط مع الحقل txt_name الذي بعد تشغيل التحديث سوف يمسح التشكيل حسب الكود. jتم التعديل بإضافة الكود المقترح من الأخ ناقل، و عليه هناك طريقتين للتحديث إزالة التشكيل من الكلمات.rar

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

تسلم - تمام تم الأمر

وعليكم السلام-عليك بإستخدام هذا الكود Sub run() Range("a65536").End(xlUp).Select End Sub الذهاب الى اخر صف مكتوب.xlsm

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

أخى الكريم / حسين مامون يعجز لسانى عن الشكر و لكن أدعو الله أن يزيدكم من علمة و فضلة

اخي الكريم اعطينا هذا الموضوع اكثر مما يستحق وهذا مخالف لقانون المنتدى وكل هذا لانك لم توصل الفكرة عما تريد بلغة الاكسيل لاخر مشاركة ارجو ان تشرح ما دور الكود الدي تتحدث عنه ادا طبق ايعمل على العمودE الكود في مشاركتي السابقة يغي بالغرض وينبهك في بملاحضة بالعمود F انسخه وضعه في حدثworkbook_open ارجو بعض الاخوة الاطلاع على الملف وابداء اراء لان الاخ يقول الملف لايفتح عنده تحياتي

تفضل هذا الكود لأنشاء نسخة احتياطية اخي الكريم انسخ و الصق فقط - سيتم انشاء مجلد لحفظ النسخة الاحتياطية بجوار قاعدة البيانات - يتم حفظ نسخة من قاعد البيانات بتاريخ اليوم - سيتم انشاء جدول جديد يحتوي على اسم النسخة و تاريخها و موقعها Dim fso As Object Dim fldrname As String Dim fldrpath As String Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\Backup" If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If Dim MyFile, DstFile As String Dim Syso As Object On Error GoTo ErrH MyFile = CurrentProject.FullName DstFile = CurrentProject.Path & "\Backup\Backup-" & Format(Date, "dd-mm-yyyy") & ".accdb" DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing Name DstFile As DstFile & ".ptc" DBEngine.CompactDatabase DstFile & ".ptc", DstFile Kill DstFile & ".ptc" DoCmd.RunSQL "CREATE TABLE Backup (Backup_NO INT , Backup_Name VARCHAR (50) , Backup_Path VARCHAR (100), Backup_Date Date);" Dim db As DAO.Database Dim MaxBackup_NO As Integer MaxBackup_NO = Nz(DMax("[Backup_NO]", "[Backup]"), 0) + 1 Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("Backup") With rs .AddNew ![Backup_NO] = MaxBackup_NO ![Backup_Name] = Format(Date, "dd-mm-yyyy") ![Backup_Path] = DstFile ![Backup_Date] = Now() .Update End With MsgBox "تم انشاء قاعدة البيانات بنجاح" & vbNewLine & "Database successfully created" & vbNewLine & vbNewLine & "" & "اسم قاعدة البيانات" & vbNewLine & "The name of the database" & vbNewLine & "" & vbNewLine & "Backup-" & Format(Date, "dd-mm-yyyy") & vbNewLine & vbNewLine & "" & "مسار القاعدة الجديدة" & vbNewLine & "Path of the new rule" & vbNewLine & "" & vbNewLine & DstFile, vbMsgBoxRight + vbOKOnly, "emphasis" & "/" & "تاكيد" Exit Sub ErrH: Select Case Err.Number End Select

السلام عليكم ورحمة الله ضع المعادلة التالية فى اول خلية ثم اضغط Ctrl + Shift + Enter ثم اسحب المعادلة افقيا و رأسيا =IFERROR(INDEX(البيانات!$B$686:$I$712;MATCH(($B2&"*?");البيانات!$B$686:$B$712&البيانات!C$686:C$712;0);COLUMN()-1);"")

أخي أبا ياسين لا داعي لاستخدام CurrentDirectory فـ Mypath تلتقط المسار الحالي للبرنامج

وعليكم السلام ورحمة الله وبركاته يأخي ضع ملفك ليتم عليه التعديل وشكرا

اطلع علي المرفق بالموضوعين التاليين لعلك تجد ما تريد والثاني

برجاء ارفاق الفايل للتعديل علية

فكرة علي سريعة علي حسب ما فهمت في حدث عند الفتح النموذج اجعل متغير عام وفي حدث عند الخروج من النموذج اسند قيمة n2 للمتغير العام في فتح النموذج وهكذا تكون القيمة معك تستخدمها من أي مكان خارج النموذج

كان يجب رقع ملف للمعالجة لكن اليك هذا النموذج الذي يمنع التكرار في العامودين الأول والثاني (النظاق الأخضر) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim x%, RG As Range x = Cells(Rows.Count, 1).End(3).Row Set RG = Range("A1:B" & x) Application.EnableEvents = False If Not Intersect(Target, RG) Is Nothing And _ Application.CountA(Range("A" & Target.Row).Resize(, 2)) = 2 Then RG.RemoveDuplicates Array(1, 2) End If Application.EnableEvents = True End Sub الملف مرفق No_dups.xlsm

أكسس ليس بحاجة إلى أن تزعي عنه الأمان أو تخفضيه! أكسس بحاجة إلى أن تمنحيه مكاناً آمن ليعمل منه بحرية! أكسسي منحته الحرية الكاملة للعمل من أي مكان على حاسبي بهذه الطريقة..

السلام عليكم ورحمه الله وبركاته ممكن عمل برنامج يتكون من عمود لرقم التسلسل من ١ الى ٢٠٠ وعمود لاسماء الموظفين و٦ اعمده لاسماء الوثائق وواحد للملاحظات بحيث يوضع تحت اسم كل وثيقه تخص موظف معين تاريخ انتهائها بالميلادي ويتم التلوين بالاصفر اذا بقي على انتهائها ٣ شهور والبرتقالي شهرين والاحمر شهر والاسود اذا انتهى تاريخها وبخاصية البحث عن اسم الموظف ويكون سهل الاستخدام شكر لكم

المطلوب عند ادخال تاريخ انتهاء الوثائق(مكتوب في الملف يوضع تاريخ الانتهاء) ويبقى لها ٣ اشهر ع انتهائها تتلون بالاصفر اذا شهرين برتقالي اذا شهر احمر اذا انتهت بالازرق الهدف منه لدي موظفين (150 موظف) وكل موظف له تقريبا ٧ وثائق لها تاريخ انتهاء واريد اعرف من خلال البرنامج متى تنتهي كل وثيقه لكل موظف ومرفق صوره للتوضيح

Sale = ([Buy] * [Nesba]) / 100 + [Buy] 331.mdb

تفضل أخى محمود فلتر.xlsm

تفضل أخى محمود الغاء الفلترة.xlsm

هل ينفع معك هذا الملف ؟ علامات.xlsm

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

او هناك طريقة اخرى وهي زيادة تغيير حجم تباعد الاحرف الى 300 % مثلا حسبما تريد . من مربع الحوار "خط" من التبويب تباعد الاحرف نكتب النسبة المئوية التي نريدها لهذه الاحرف او طريقة اخرى :: ابقاء الضغط على المفتاح SHIFT والنقر على مفتاح الحرف التاء (نقرة او اكثر) فلكل نقرة واحدة مسافة ابتعاد بين الحرف والحرف الذي نريده ان يبتعد عن هذا الحرف. والسلام عليكم

للرفع رفع الله قدركم