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

تفضل التعديل New folder (2).zip

تفضل هذا التعديل odbExe2.zip

أهلا بك.. عدل الشفرة التي أشرت إليها لتصبح كالتالي Private Sub crn_DblClick(Cancel As Integer) Dim File_Path As String, File_Name As String, Name_Path As String File_Path = Application.CurrentProject.Path & "\CONTACT\" File_Name = Dir(File_Path & Me.crn & "*.pdf") If File_Name = "" Then MsgBox "لا توجد مستندات محفوظة" Exit Sub End If While File_Name <> "" Name_Path = File_Path & File_Name Application.FollowHyperlink Name_Path File_Name = Dir() Wend End Sub النجمة في سطر المتغير File_Name تعود بأسماء جميع الملفات التي في بدايتها ذات الرقم. راجع ملف التعليمات لمزيد من التوضح حول التابع Dir

ما شاء الله الكودين ممتازين مبدعين جزاكم الله خيرا

السلام عليكم ورحمة الله وبركاته : مثال عندما اكتب في التكست بوكس1 رقم (2 او 5 او 8 ) يعرض لي في (تكست بوكس2) كلمة " العراق" وعندما اكتب رقم (7 او 4 او 3) يظهر لي في تكست بوكس 2 كلمة " مصر" وهكذا () Private Sub TextBox1_Change If Me.TextBox1.Value = "2" Then "العراق"= TextBox2.Value Else "" = TextBox2.Value End If End Sub فورم.xlsm

احسنت استاذنا العزيز . بارك الله بجهودك

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

لكي يتم هذا يجب تحديد مكان تشغيل الملف التنفيذي مثلا في المسار D:\folder\file.exe مع تغيير اسم البارتيشن والمجلد والملف حسب احتياجاتك وفي حدث عند فتح ملف الاكسل يتأكد من وجود الملف التنفيذي في المسار المحدد فإذا كان موجودا يفتح البرنامج وإلا فيظهر رسالة يجب وضع البرنامج في المسار ..... كذا بكود مثل هذا Private Sub Workbook_Open() strpath = "D:\folder\file.exe" If Dir(strpath) = "" Then MsgBox "يجب وضع البرنامج في هذا المسار حتى يعمل" & chr(10)& strpath thisworkbook.close 1 End If End Sub وفي كود حذف الملف يتم إضافة سطر لحذف الملف التنفيذي kill "D:\folder\file.exe" بالتوفيق

يمكنك استعمال هذا الكود Private Sub TextBox1_Change() txt = Val(Me.TextBox1.Value) If txt = 2 Or txt = 5 Or txt = 8 Then Me.TextBox2.Value = "العراق" ElseIf txt = 3 Or txt = 4 Or txt = 7 Then Me.TextBox2.Value = "مصر" Else Me.TextBox2.Value = "" End If End Sub بالتوفيق

هذه عملية بحث بسيطة يمكن استخدام الكثير من معادلات البحث وأبسطها استعمال هذه المعادلة في الخلية E3 =VLOOKUP(D3, A1:B100,2, 0) حيث الرقم مكتوب في D3 بالتوفيق

انشاء الله يتفاعل الاخوة معنا شكرا استاذ حسام

جزاك الله خيرا استاذ محمد بالنسبة لمضاد الفيروسات فهو يتعامل مع ملف تحويل الاكسل على انه فيروس ( علما باني قمت بتحميله من موضوع تحويل الاكسل الى ملف تنفيذي بالمنتدى وبالنسبة للكود Option Explicit Private Const MSG_TITLE As String = "Deleting Current Workbook ..." Private Const MSG_TEXT As String = _ "You are about to permanently delete the current workbook located in :" Sub Kill_Myself() Dim lUserDecision As Long Dim sMsg As String On Error Resume Next sMsg = "Attention !" & vbNewLine & vbNewLine sMsg = sMsg & MSG_TEXT & vbNewLine sMsg = sMsg & "'" & ThisWorkbook.FullName & "'" & vbNewLine sMsg = sMsg & "from Disk!!" & vbNewLine & vbNewLine sMsg = sMsg & "Go ahead ?" & vbNewLine & vbNewLine Beep lUserDecision = _ MsgBox(sMsg, vbExclamation + vbYesNo, MSG_TITLE) With ThisWorkbook If lUserDecision = vbYes Then .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End If End With End Sub وهو في موضوع

جزاكم الله خيرا، ورزقكم سعادة. الدارين

تفضل هذا Microsoft Access Database جديد (3).zip

الملف ليس به أكواد سوى Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False End Sub وتعني عند تغير تحديد الخلايا يتم إيقاف خاصية تحديث الشاشة وهو موجود في بعض الشيتات وهذا الكود يمكن حذفه وكود آخر في موديول1 Sub save() ThisWorkbook.save End Sub وهو لحفظ هذا المصنف وتمت اضافة ماكرو يعرض رسالة وحذف حدث عند تغيير التحديد في جميع الشيتات يفضل تجربة هذا المرفق وملاحظة هل المشكلة مازالت مستمرة أم لا بالتوفيق مخازن شتوي 2022.rar

يفضل إرفاق الملف حتى نتمكن من تجربته ونرى هل المشكلة في الملف أم في برنامج الاكسل لديكم

الدالة صحيحة بلا أي مشاكل وظيفتها جمع الأرقام من مدى به نصوص وأرقام بينهما مسافة ربما يكون الخطأ في وضع أول سطر من الدالة بجوار التعريف بها حيث أن الترتيب الصحيح هكذا Function SumNumOnly(rngS As Range, Optional strDelim As String = " ") As Double Dim xNums As Variant, lngNum As Long xNums = Split(rngS, strDelim) For lngNum = LBound(xNums) To UBound(xNums) SumNumOnly = SumNumOnly + Val(xNums(lngNum)) Next lngNum End Function بالتوفيق

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

أستاذ / محمد الأوفيس 32 بت واويندوز 64 بت والملفات كانت تعمل بكفاءة على هذا الوضع بالملفات القديمة ملفات xlsb وهى مهمة جدا بالنسبة لي وحجمها كبير نسبيا أما الملفات الجديدة فهى تعمل بامتداد xlsb هل أعيد تثبيت الويندوز والمشكلة بالماكرو طبعا ولك جزيل الشكر

أ/محمد اشكرك الله يعطيك العافية وفقك الله استاذي الفاضل

تفضل هنا حلين بعد تغيير اتجاه الخلايا وتغيير مكان البداية في شيت H-5 واحد بدالة offset وواحد بالتركيبة المطلوبة بالتوفيق how-can-get-data-from-other-sheets_2.xlsx

جميعا بإذن الله

لا يوجد مشكلة في إثراء الموضوع ولكن حتى يتم جلب بيانات عمود النسبة تحتاج إلى إضافة سطر وتعديل آخر sh.Cells(m, 8).Value = ws.Cells(r, 12).Value sh.Cells(m, 9).Value = ws.Cells(r, 13).Value For Each x In Array(2, 3, 8, 9) ليصبح الكود كاملا Sub Test() Dim x, ws As Worksheet, sh As Worksheet, r As Long, m As Long, c As Long, n As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Sheet1") Set sh = ThisWorkbook.Worksheets("2") With sh.Range("B2").CurrentRegion.Offset(1) .Cells.UnMerge: .ClearContents End With m = 3 For r = 4 To ws.Cells(Rows.Count, "B").End(xlUp).Row sh.Cells(m, 2).Resize(, 2).Value = ws.Cells(r, 2).Resize(, 2).Value n = 4 For c = 4 To 10 Step 2 sh.Cells(m, n).Value = ws.Cells(r, c).Value sh.Cells(m + 1, n).Value = ws.Cells(r, c + 1).Value n = n + 1 Next c sh.Cells(m, 8).Value = ws.Cells(r, 12).Value sh.Cells(m, 9).Value = ws.Cells(r, 13).Value For Each x In Array(2, 3, 8, 9) sh.Cells(m, x).Resize(2).Merge Next x m = m + 2 Next r Application.ScreenUpdating = True End Sub بالتوفيق

Rem In UserForm Module Rem ------------------ Private Sub UserForm_Initialize() Dim a With ThisWorkbook.Worksheets(1) a = MergeRanges(.Range("AH2").Resize(Application.CountA(.Columns("AH"))), .Range("W2").Resize(Application.CountA(.Columns("W")))) End With Me.ComboBox1.List = a End Sub Rem In Standard Module Rem ------------------ Function MergeRanges(ParamArray args()) Dim e, cell As Range ReDim temp(0) For Each e In args For Each cell In e If cell <> "" Then temp(UBound(temp)) = cell ReDim Preserve temp(UBound(temp) + 1) End If Next cell Next e ReDim Preserve temp(UBound(temp) - 1) MergeRanges = Application.Transpose(temp) End Function

تفضل التعديل ترتيب رقم 3 - نقل طالب واحد - نقل جميع الطلاب في المجموعة رقم 2 listboxSearch (4).zip

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

يمكنك استعمال هذا الكود في حدث تهيئة النموذج والاستغناء عن إجراء add_comp Private Sub UserForm_Initialize() With Sheets("الصفحة الرئيسية") Lr = .Cells(Rows.Count, 23).End(xlUp).Row lr2 = .Cells(Rows.Count, 34).End(xlUp).Row For n = 2 To lr2 Me.ComboBox1.AddItem .Range("ah" & n) Next n For n = 2 To Lr Me.ComboBox1.AddItem .Range("w" & n) Next n End With End Sub مع تعديل خاصية عدد الأعمدة ColumnCount إلى 1 في خصائص ComboBox1 بالتوفيق

الف شكر على الرد لاكن للاسف الكود لم ينجح يا غالي

هذا الملف السابق في المشاركة السابقة بعد اضافة التواريخ الجديدة ..... انظر المرفق ..... Microsoft Access Database جديد (1).accdb

تفضل هذا التعديل على نفس مربح التحرير و السرد الي موجود من قبل السبب ان من كبر النموذج ما انتبهت انك اضفت مربع تحرير و سرد فيه الشهور كذلك نصيحة لك حاول مثل هذي النماذج انك ما تجعلها بحجم كبير لجل انها تناسب جميع الشاشات لو لاحظت اني صغرت حجم النموذج لكن عند الفتح ياخذ حجم الشاشة Microsoft Access Database جديد (3).zip

شكرا لمروركم الكريم أستاذ @خالد القدس نفعنا الله جميعا بما علمنا وعلمنا ما ينفعنا

تفضل هذا التعديل Microsoft Access Database جديد (3).zip

بعد تحميل الملف من الموضوع الأصلي لا يوجد أية مشكلة في الملف ربما تكون قد أجريت بعض التغييرات على الملف جعلته يظهر هكذا أو أن إعدادات اللغة العربية في جهازك غير صحيحة

Hello Make sure the direction of language is Arabic before copying the codes and also make sure you have installed Arabic from Windows Settings

Sub Test() Const rAddress As String = "A2:J10" Dim ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("ROW") sh.Cells(1).CurrentRegion.Offset(1).ClearContents For Each ws In ThisWorkbook.Worksheets If ws.Name <> sh.Name Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 Set r = ws.Range(rAddress) sh.Range("A" & m).Resize(r.Rows.Count, r.Columns.Count).Value = r.Value End If Next ws Application.ScreenUpdating = True End Sub

ارفع ملف علشان نستطيع ان ننفذ عليه طلبك

Remove extra spaces in the months in column A then use this formula =NETWORKDAYS.INTL(1&D4,EOMONTH(1&D4,0),"1111011")

* لا لن تضاف تلقائيا ؛ لأنك حددت مصدر بيانات الجدول المحوري من A1:H6 وحتى تضاف تلقائيا يجب تنسيق المدى الموجود في ورقة1 كجدول format as table من تبويب الصفحة الرئيسية home ثم تعديل مصدر بيانات الجداول المحورية change data source إلى نفس المدى في ورقة1 ولكن هذه المرة سيظهر المدى باسم جدول1 أو table1 * لتعديل عناوين في الجداول المحورية مثل rows labels & columns labels & grand total يتم تحديد الخلية ثم كتابة التسمية المطلوبة ثم ضغط مفتاح الادخال Enter بالتوفيق

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

بعد إذن أخي الكريم @عبدالفتاح في بي اكسيل كانت لي محاولة في هذا الشأن منذ عام 2011 في الأكسس فقمت بتطويع الكود للعمل مع نماذج الاكسل فقط يتم تحديد أفضل عرض bestw وأفضل ارتفاع besth في الكود في حدث UserForm_Initialize وهما دقة الشاشة التي تم التصميم عليها بالتوفيق resizeform.xlsb

أخي الكريم Gamor هذا كود بسيط يمكنك استعماله وتوظيفه كما تشاء الأخ الفاضل gelani يرجع هذا لاستعمالك نظام تشغيل 64 بت تم وضع نفس الملف لنسخة 64 في المشاركة الأولى الصديق الكريم. ابوخليل كلامك صحيح جدا ولكن كان هذا هو المتاح في عام 2009 تحياتي

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

شكرا freemasn

أستاذ / رضا مهران تفضل تعديلات على البرنامج ضع أسماء الوظائف بالترتيب في العمود Z واكتب اسم وظيفة كل موظف في العمود O شئون عاملين 2019.rar

كلمة المرور : 12345

هل البرنامج لم ينل رضا الإخوة؟ أم المجال نفسه لا يوجد اهتمام به؟ رغم وجود معادلات وشغل عالي جدا فيه على العموم أرحب بآرائكم واقتراحاتكم أخوكم محمد صالح

مشكور أخي yamz شاهدت أمثله مثل هذا لكأس العالم وكأس أوربا جزاك الله خيرا

رائع أخي أحمد جزاك الله كل خير

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

مشكور أخي أحمد يعقوب وإذا سمحت لي فهذه هديتي لك وللإخوة ‏طريقة إنشاء شريط أدوات جديد في اكسل و ارفاقة مع ملف محدد o من القائمة عرض تختار اشرطة الأدوات ثم تخصيص o سوف تظهر معاك الصفحة التالية o تضغط على جديد سوف يظهر لك مربع حوار التالي o تدخل هنا الإسم الذي تريده لشريط الأدوات الجديد ثم موافق o سوف يظهر لديك شريط ادوات جديد خالي من أذارير o تنتقل الى تبويب الأوامر o ثم تختار بواسطة الماوس أي امر تريدة وتسحبة و تفلته داخل شريط الأدوات الجديد o من هنا بعد عملية السحب o يمكنك الآن تغيير شكل الزر o تغيير اسم الزر o وعدة خيارات اخرى باستخدام كليك يمين على الزر الذي تريد o = = = = = = = = = = = = = = = o ((اضافة شريط الأدوات الى ملف معين)) o بعد الإنتهاء من عمل الشريط الجديد o تعود الآن الى تبويب أشرطة الأدوات مرة اخرى o و بالضغط على زر ارفاق000 o تظهر لك الشاشة التالية o داخل هذه الشاشة يوجد لديك كل أشرطة الأدوات التي تم إضافتها من قبل المستخدمين إلى اكسل o تحدد شريط الأدوات الذي تريده – ثم تضغط على نسخ o الآن بعد الضغط على موافق o أصبح شريط الأدوات المحدد مقترن تماما مع ملف اكسل المفتوح و النشط حاليا أحفظ الملف و اغلقة عند تشغيل هذا الملف في أي جهاز كمبيوتر آخر سوف يظهر تلقائيا شريط الأدوات المختار مع تحياتي و تقديري