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

السلام عليكم طال غيابي عنكم احبتي في الله لسببين اولهما ضروف خاصة وثانيها لتوجهي الى تعلم لغات برمجة اخرى و ابتعادي عن الاكسل العشق فلما اخذني الحنين للاكسل فكرة لمذا لا استخدمه كما تعلمت مع اللغات الاخرى فرفعت التحدي و عملت هدا البرنامج البسيط البرنامج عبارة عن تسجيل عمليات استلام وتسليم الوصلات وظهار كشف الحساب لكل مورد على حدى او تقرير عام بصفة عامة البرنامج بسيط ما يهم هو ما يخفيه من اخواد و مايضهره من جمال للفورم اما الثانية ما يضهره من جمال الفورم حاولت ان اعمل ما يستخدم في c# ui design و النتيجة هي اما الاولى مايخفيه من اكواد هي قاعدة البيانات هي اكسيس بحيث برمجة كلاص يمكنك استخدامه لتتعامل مع ملفات الاكسيس بكل سهولة ابتداءا بجملة الاتصل فتح الاتصال اغلاق الاتصال الى تنفيذ الكموند تماما كما هو الحال مع c# او غيرها من لغات اخرى الى كل من يبحث عن كيفية العمل على برنامج واحد باكثر من جهاز او مستخدم في نفس الوقت هذا الملف يمكنك من ذلك وذالك برفع قاعدةالبيانات الاكسيس على اي استضافة كقوقل دريف او دريفبوكس وتسليم ملف الاكسل للمستخدمين سيستطيعون جميعهم العمل عليه في نفس الوقت كل ما تحتاجه هو تغيير مسار الملف في كلاص الاتصال المسمى ClsConnctionDB في الاخير تحياتي للجميع WPFVBA.rar

عليك السلام ورحمة الله وبركاته ولك بمثل ما دعوت جرب هذا الفورم list box.xlsm

بعد اذن الاخوة الزملاء قم بتغيير الكود Dim x As Integer الى Dim x As Long

السلام عليكم المفروض يكون الكود بدالة (if ) كالتالي If rs!No.Value = Me.MNo Then DoCmd.OpenForm "Dashboard" Else DoCmd.OpenForm "Copy" End If

اخوتي واساتذتي الكرام .. أضع بين أيديكم البرنامج مفتوح المصدر البرنامج مكون من عدة اجزاء الجزء الاول وهو البرنامج الرئيسي protection_trial وهو المسؤول عن قراءة مكونات جهاز العميل (قراءة سيريال الـ UUID و اسم المعالج) لتوليد رقم نسخة فريد خاص بجهاز العميل يقوم العميل بارساله الى المبرمج. ملاحظة1: في البداية وقبل ارسال البرنامج لاي عميل قم برفع المستند النصي المرفق Active1.txt الى موقع الـ dropbox واعمل للمستند مشاركة واستخرج من رابط المشاركة رمز مشابه لهذا الرمز (n702324j1aclxel) واستبدله في البرنامج لديك If CheckNetFile("https://dl.dropboxusercontent.com/s/n702324j1aclxel/active1.txt?dl=0") = True Then MyString = Decrypt(RTrim(LTrim(GetFromWebpage("https://dl.dropboxusercontent.com/s/n702324j1aclxel/active1.txt?dl=0")))) If MyString = "" Then MyString = Decrypt(RTrim(LTrim(ReadURLFile("https://dl.dropboxusercontent.com/s/n702324j1aclxel/active1.txt?dl=0")))) الخطوة السابقة تفعلها للمرة الاولى فقط. الجزء الثاني من البرنامج وهو برنامج التشفير encrept_data وهو خاص بالمبرمج حيث يقوم المبرمج بأخذ رقم النسخة السابق من العميل ووضعه في المستند النصي المرفق مع برنامج التشفير active1 -original.txt مع تحديد تاريخ بداية فترة التفعيل ونهايتها كما هو موضح داخل المستند ومن ثم فتح برنامج التشفير ومة خلال النموذج الاول frm اضغط مباشرة على كلمة تشفير النص وذلك لتوليد مستند نصي آخر اسمه Active1.txt فيه تشفير لبيانات المستند النصي السابق .. قم برفع المستند النصي Active1.txt على موقع الـ dropbox بدون حذف الملف القديم الموجود على الموقع ( فقط ارفعه على نفس المكان ليقوم الموقع باستبدال الملف القديم بالجديد تلقائياً بدون تغيير رابط المشاركة) في كل مرة تقوم باضافة عميل جديد كل ماعليك القيام به هو فتح مستند النص active1 -original.txt ثم قم باضافة رقم نسخة العميل وتاريخ فترة تفعيل البرنامج ومن ثم تشغيل برنامج التشفير encrept_data ومن ثم رفع المستند النصي الناتج Active1.txt الى موقع الـ dropbox مباشرة في نفس مكان الملف القديم مع مراعات عدم حذف القديم لكي لاتفقد رابط المشاركة وهذا أمر هام جداً يرجى الانتباه له تحياتي encrept_data.zip protection_trial.mdb

وهذه طريقة بدالة Case Dim i As Integer Dim db As DAO.Database Dim rs As DAO.Recordset Dim x As Integer Set db = CurrentDb Set rs = db.OpenRecordset("Table1") x = rs!No.Value Select Case Me.MNo Case Me.MNo If x = Me.MNo Then DoCmd.OpenForm "Dashboard" Else DoCmd.OpenForm "Copy" End If Case Else End Select تحياتي

راجع قراءة موضوع حبيبنا @ابوخليل هنا

استخدم هذه المعادلة في الخلية E2 واسحب يميناً عامود واحد و نزولاً الى اخر صف =Separate_col($C2,"\W+\d+",COLUMNS($E$1:E1)) الكود Option Explicit Function Separate_col(rg As Range, my_expression, n) Dim Obj As Object Dim matches, x, i, cnt% Dim NowArray(), Match Set Obj = CreateObject("vbscript.regexp") With Obj .Pattern = my_expression .Global = True .IgnoreCase = True End With '+++++++++++++++++++++++++ Set matches = Obj.Execute(rg.Value) x = matches.Count If x = 0 Then Separate_col = "N/A": Exit Function '============================ ReDim NowArray(x - 1) For Each Match In matches NowArray(cnt) = Match.Value cnt = cnt + 1 Next If n - 1 > UBound(NowArray) Then Separate_col = "N/A": Exit Function Separate_col = NowArray(n - 1) Set Obj = Nothing End Function الملف مرفق UDF_FORMULA.xlsm

الكود بالشكل بالتالي يعمل ان شاء الله Dim i As Integer Dim db As DAO.Database Dim rs As DAO.Recordset Dim x As Integer Set db = CurrentDb Set rs = db.OpenRecordset("Table1") x = rs!No.Value For i = 0 To 2 If x = Me.MNo Then DoCmd.OpenForm "Dashboard" ElseIf x <> Me.MNo Then DoCmd.OpenForm "Copy" End If Next i واعتقد انك لو استخدمت الكود بدون For ... Next سيكون افضل Dim i As Integer Dim db As DAO.Database Dim rs As DAO.Recordset Dim x As Integer Set db = CurrentDb Set rs = db.OpenRecordset("Table1") x = rs!No.Value If x = Me.MNo Then DoCmd.OpenForm "Dashboard" ElseIf x <> Me.MNo Then DoCmd.OpenForm "Copy" End If تحياتي المعذرة استاذتا الفاضل @خالد سيسكو لم انتبه الى ردك فارجو المعذرة ولك الشكر تحياتي

استبدل الجملة CurrentProject.Path & "\Pic" بهذه الجملة "D:\New folder\Pic"

فورم تسجيل البيانات والبحث عنها مع الصور الفيديو

تفضل اخي الكريم StuSaifi.rar تحياتي

السلام عليكم بعد اذن الاستاذ محمد ابوعبد الله انت عامل بالجدول الرقم No(مزدوج ) غيره الى عدد صحيح طويل

تفضل اخي الكريم Private Sub Form_Open(Cancel As Integer) Dim i As Integer Dim db As DAO.Database Dim rs As DAO.Recordset Dim x As Long Set db = CurrentDb Set rs = db.OpenRecordset("Table1") x = rs!No.Value Select Case Me.MNo Case Me.MNo If x = Me.MNo Then DoCmd.OpenForm "Dashboard" DoCmd.Close acForm, "Copy" Else DoCmd.OpenForm "Copy" DoCmd.Close acForm, "Dashboard" End If Case Else End Select End Sub Loop.rar

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

وهذه ايضاً طريقة بدالة Case Dim XN As String XN = Me.XLetter.Column(1) Select Case XN Case Is = "A" Me![Text7] = 1 Case Is = "B" Me![Text7] = 2 Case Is = "C" Me![Text7] = 3 Case Is = "D" Me![Text7] = 4 Case Is = "E" Me![Text7] = 5 End Select مع استكمال باقي الحروف تحياتي

تفضل اخي الكريم توجد اكثر من طريقة لفعل ذلك ارفقت لك طريقتين db1.rar تحياتي

مثالين آخر ين للتقويم لاحد الاخوة التقويم.rar NA_Calendar2000-1.rar

مشكور على إهتمام سيادتكم و مساهمتك المتميزة تقبل تقديرى و إحترامي

اخي الفاضل سبق حل هذا السؤال من الاستاذ بن عليه حاجي والاستاذ سليم حاصبيا https://www.officena.net/ib/topic/98022-فصل-المادة-عن-الشعبة-في-حقل-مستقل/ تحياتي

رائع استاذنا المبدع دائما استاذ سليم وفقكم الله

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

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

جرب هذا الماكرو Option Explicit Sub Get_dif() Dim M As Worksheet, NT As Worksheet, NZ As Worksheet Dim LM As Single, LN As Single, i As Single Dim Dic_M As Object, Dic_N As Object Set M = Sheets("المالية") Set NZ = Sheets("النظام") Set NT = Sheets("النتائج") Set Dic_M = CreateObject("Scripting.Dictionary") Set Dic_N = CreateObject("Scripting.Dictionary") NT.Range("a1").CurrentRegion.ClearContents LM = M.Cells(Rows.Count, 1).End(3).Row LN = NZ.Cells(Rows.Count, 1).End(3).Row For i = 1 To LM If M.Range("A" & i) <> "" Then Dic_M(M.Range("A" & i).Value) = "" End If Next For i = 1 To LN If IsError(Application.Match(NZ.Range("A" & i), Dic_M.keys, 0)) Then Dic_N(NZ.Range("A" & i).Value) = "" End If Next NT.Range("A1").Resize(Dic_N.Count) = _ Application.Transpose(Dic_N.keys) Set Dic_M = Nothing: Set Dic_N = Nothing End Sub الملف مرفق Jard_Mali.xlsm

استاذ صالح بصراحة البرنامج عبارة عن ايقونة كودات لكن المشكلة في شغلات بدوخ ومدا اكدر افهم انت كيف عامل برمجتة في عندك قناة للشروحات ياريت نستفاد من جنابك الكريم . تحياتي

أ.ليث ليث ضع PtrSafe بعد Declare لأن نسخة الأوفيس عندك 64 بت بالتوفيق

اوك .. تقدر تضيف كود الارجاع لاول سجل في اخر الكود علشان لو ضغط مره ثانيه يكون المؤشر واقف عند الاول ويعيد نفس السجلات Docmd.gotorecoed ,,acfirst

يجب تحديث البيانات بالضغط على الزر اضغط هنا

وعليكم السلام-تفضل قوائم.xlsm

السلام عليكم أخي محمد أهنئك على صبرك و مثابرتك في طلب الحل دون المساس أو التعدي على قوانين المنتدى. لذلك قمت بتصميم مثال شمال لما تحتاجه. و هو كالتالي: 1- تختار قاعدة البيانات في المربع الأول 2- تظهر جميع نماذج القاعدة في المربع الثاني 3- تظهر أسماء مربعات نص النموذج المختار في المربع الثالث نقوم بالضغط على زر الأمر فتظهر رسالة تقول أن النموذج مفتوح أو مغلق و إذا كان مفتوح تظهر رسالة أخرى بها قيمة مربع النص التحكم في نماذج قاعدة بيانات خارجية.rar

الموضوع جديد جميل قوي الاخ الراشدي موسى شاهد المرفقات Test_1.rar

المرفق بحث في نفس الملف في كل الصفحات وترحيل الى شيت.xlsm

السلام عليكم تفضل اخي العزيز XLtoEXE.rar

تم عمل المطلوب وجود الخلايا الفارغة في الجدول يسبب هذه المشكلة ttt_new.xlsm

السلام عليكم الاخ الكريم / S0bhy بارك الله فيك الملف المرفق منك لم اتمكن من فك الضغط الخاص به ولكن اليك المرفق اظن به ما تريد ... شاهد المرفق واشعرنا بالنتائج ( قم بالوقوق علي الصف الذي تريد نسخه بمعادلاته وتنسيقاته في اي خليه فيه ثم اضغط علي الزر الاحمر الموجود بالملف ستظهر لك نافذة تتطلب منك عدد الصفوف المراد اضافتها قم بوضع العدد الذي تريد اضافته ثم اضغط موافق ستتم الاضافة ) تقبل خالص تحياتي نسخ واضافة الصفوف المطلوبه بمعادلاتها وتنسيقاته.xls

اثراء للموضوع هذا الملف (بعد ان فهمت عليك ماذا تريد) Count_sharikat.xlsx

السلام عليكم انشأت اوراق لأشهر وهمي يشترط اذا ضفت اوراق اخرى لاشهر تسميها بنفس الطريقة وعمود ارقام الايام في Sheet1 تسجل التاريخ لليوم وليس ارقام الايام كود بسيط اضافة الى حلول الاساتذه الافاضل تفضل المرفق ترحيل بيانات_1.xls

السلام عليكم ورحمة الله تم عمل المطلوب في الملف المرفق... test 1.xlsx

تم التعديل كما تريد Option Explicit Sub transfer_data() Dim Source_sh As Worksheet Dim Target_sh As Worksheet Dim last_ro%, N_ro% Set Source_sh = Sheets("ورقة1") last_ro = Source_sh.Cells(Rows.Count, 3).End(3).Row If last_ro < 10 Then Exit Sub Select Case Source_sh.Range("c2") Case "أ": Set Target_sh = Sheets("نوبة أ") Case "ب": Set Target_sh = Sheets("نوبة ب") Case "ج": Set Target_sh = Sheets("نوبة ج") Case "د": Set Target_sh = Sheets("نوبة د") Case "ه": Set Target_sh = Sheets("نوبة ه") Case "و": Set Target_sh = Sheets("نوبة و") End Select N_ro = Target_sh.Cells(Rows.Count, 1).End(3).Row + 1 Target_sh.Range("a" & N_ro).Resize(last_ro - 9, 6).Value = _ Source_sh.Range("B10").Resize(last_ro - 9, 6).Value End Sub الملف مرفق EHSAA3_1.xlsm

السلام عليكم ورحمة الله وبركاته اخواني الاكارم تحية طيبة وبعد : الدالة Split هي المسؤلة عن تقسيم السلسلة النصية ويمكننا من خلالها ارجاع أو حذف الجزء الذي نحدده ويتم توظيفها في النماذج والتقارير داخل محرر الفيجوال على النحو التالي : name1 = Split(FullName, " ")(0) name2 = Split(FullName, " ")(1) name3 = Split(FullName, " ")(2) name4 = Split(FullName, " ")(4) - باعتبار FullName هو حقل الاسم الكامل علما انه يمكن كتابة الاسم داخل الكود بين علامتي تنصيص مزدوجتين وستقوم الدالة بارجاع الجزء المحدد - وما بين علامتي التنصيص " " الفاصلة التي على اساسها يتم تجزئة النص وهي هنا مسافة فارغة - اما الارقام (0) ، (1) ، (2) ... فهي ترمز الى مكان الجزء داخل النص الى هنا كل شيء يسير على ما يرام ولكن حين نريد استخدامها داخل الاستعلام نفاجأ بأنها لا تعمل وتظهر رسالة من الاستعلام بأن هذه الدالة غير معروفة والحل : ان نعقد بين الدالة والاستعلام صفقة عمل و تعارف ولن يتم لنا ذلك حتى نوجد للدالة مكان اقامة دائم في قاعدة البيانات الحالية وللدرس بقية : تعريف الدالة + التطبيق ان شاء الله

أولا : تطبيق الفكرة داخل النموذج في حقول غير منضمة On Error Resume NextDim x As Integer x = Len([txtNm]) - Len(Replace([txtNm], " ", "")) 'هذا السطر لعد الفواصل بين الأسماء name1 = Split(txtNm, " ")(0) ' الصفر يعني ما قبل الفاصلة الأولى ​ 'اذا كان عدد الفواصل=1 يعني اسمين فقط سيتم تعييين الاسم الثاني كاسم عائلة If x = 1 Then name4 = Split(txtNm, " ")(1) If x = 2 Then name4 = Split(txtNm, " ")(2) ' If x = 3 Then name4 = Split(txtNm, " ")(3) ' If x = 4 Then name4 = Split(txtNm, " ")(4) ' وفي المثال غنية عن زيادة المقال يتبع .. _تجزئة النص في النموذج حسب التحديد .rar

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

هل تقصد أنه لديك عملاء و تريد كل شهر اضافة مبلغ الاشتراك لهذا العميل ؟ اذا كان كذلك , جرب الاستعلام التالي INSERT INTO RASEEDB ( ZCustomerID, Out, ZDate, Eladafy ) SELECT Customer.CustomerID, Customer.Money, [Select New Date] AS Expr1, 0 AS Expr2 FROM Customer WHERE (((Customer.Net)=True)); و اذا لم يكن هو المقصود أرجو توضيح الفكرة أكثر

في تايمر الفورم اعني عداد الوقت في النموذج اضبط الفاصل الزمني لعداد الوقت على اي شيء مثلا ثانية واحدة =1000 او حتى دقيقة 60000 ثم في حدث form_Timer اكتب مثل هذا : If Time() = #10:00:00 AM# Then Call myFunction End If مع الاخذ بالاعتبار ان النموذج يجب ان يكون مفتوحا في هذا الوقت وهذا يعني ان الكود سيكون في نموذج الواجهة الرئيسي

الاخوة الكرام علي المصري ... at_aziz ..... تعليموه شكرا لمروركم وثنائكم هنا بعض المشاركات حول هذا الموضوع http://www.officena.net/ib/index.php?showtopic=43914#entry254950 http://www.officena.net/ib/index.php?showtopic=53179#entry333843

وإياك اخي الحبيب في وحدة نمطية عامة نلصق الجملة البرمجية التالية : Public Function qsplit(FullName As String, i As Integer) On Error Resume Next qsplit = Split(FullName, " ")(i) End Function لاحظ اننا انشأنا دالة جديدة بناء على الدالة الاصلية وجعلنا لها اسما قريبا من الدالة الاصلية حتى يتم التعرف عليها وعلى عملها من اول نظرة ولاحظ ايضا ما حدث لوسائط الدالة الاصلية وترتيبها حيث سيتم توظيف الدالة الجديدة داخل الاستعلام على النحو التالي : name1 : qsplit(FullName; 0) name2 : qsplit(FullName; 1) name3 : qsplit(FullName; 2) name4 : qsplit(FullName; 3) وفي المثال تطبيق للشرح والمقال : تجزئة النص.rar

اخي الكريم بالامكان عمل ذلك عن طريق استعلام على النحو التالي قم بعمل استعلام مع اضافه الجدول اليه وكتابه التعبير التالي في حقل جديد في الاستعلام Firstname: Left([fieldname] & "", InStr(1,[fieldname] & ""," ") + (InStr(1, [fieldname] & "", " ") > 0)) Lastname: Mid([fieldname] & "", InStr(1, [fieldname] & "", " ") + 1) اوارفق مثالك لتعديل عليه

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

السلام عليكم تفضل الشرح في المرفق kh_com.rar