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

السلام عليكم كما عودناكم عى كل جديد فقد قمت بتصميم برنامج خاص بمحلات الجوالات لصديق لي من المملكة العربية السعودية اضع البرنامج بين ايديكم وهو مفتوح المصدر لكي تستفيدو منه الرقم السري لاكواد فيجوال بيسك 1968 والشفت ممكن به لا تحرمونا من الدعاء mobilesv.3-KSA.rar

هل يمكن لبرنامج اكسل ان يقوم بتقسيم الصورة علي مجموعة خلايا بنسبة مئوية معينة انظر لهذا الملف لتفهم ما أقصده Complete_picture.xlsx

تفضل ::بالتوفيق:: D1.accdb

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

بارك الله فيك استاذ عبد اللطيف وزادك الله من فضله

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

ما شاء الله تبارك الله استفدنا من هذه المعلومات القيمة . شكراً لمعلمنا ابومحمد والزميل / محمد صلاح

اهلا وسهلا في الجدول نوع الحقل اختار النوع محسوب ووضعت المعيار التالي IIf(IsNull([AGA2]);[AGA1];[AGA1]-[AGA2]) ويعني اذا كان الحقل 2 فارغ تكون قيمة الحقل 3 تساوي الحقل 1 واذا لم يكن 2 فارغ تكون قيمة 3 تساوي1-2 ممتاز يا ابا ياسين بس انا فضلت عملها في الجدول لغرض حفظ القيمة للحقل 3 في الجدول ويمكن بذلك الاستفادة منها في الاستعلامات والتقارير بشكل اسهل

اتفضل بطريقه الاخ kha9009lid بس عملتها في الاستعلام 55.accdb

مشاركة مع اخي كاسر D1.accdb

ولك بالمثل شكرا لك

أخي @kaser906 شكراً لك بارك الله فيك .. حل في الصميم ومختصر نابع عن تمكن وخبرة بالأكسس .. جزاك الله خيراً .. واصلح الله شأنك .. وأدام الله خيرك وعطاك

ليس هناك مشكلة بالملف الذى ارسلته فالملف والمعادلة يعملان بكل كفاءة كما ترى أظن ان المشكلة في نسخة الإكسيل لديك فربما تستخدم نسخة اقل من 2010 او هناك مشكلة في نسخة 2019 غير مكتملة

وعليكم السلام- نورت المنتدى تفضل لك ما طلبت vehicle trip1.xlsx

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

اذا كان في الاستعلام جرب هذا IIf([AGA3]=null;[AGA1]) او هذا IIf([AGA3]="";[AGA1]) ويفضل ترفق مثال مصغر

يمكنك تجربة هذا الملف للأستاذ أحمد حمور https://www.officena.net/ib/topic/34679-دليل-هاتف-عصري-نسخه-عربيه-v2/page/3/ PHONE BOOK.xls

تفضل الكود داخل الملف #If Win64 Then Private Declare PtrSafe Function MsgBoxTimeout _ Lib "user32" _ Alias "MessageBoxTimeoutA" ( _ ByVal hwnd As LongPtr, _ ByVal lpText As String, _ ByVal lpCaption As String, _ ByVal wType As VbMsgBoxStyle, _ ByVal wlange As Long, _ ByVal dwTimeout As Long) _ As Long #Else Private Declare Function MsgBoxTimeout _ Lib "user32" _ Alias "MessageBoxTimeoutA" ( _ ByVal hwnd As Long, _ ByVal lpText As String, _ ByVal lpCaption As String, _ ByVal wType As VbMsgBoxStyle, _ ByVal wlange As Long, _ ByVal dwTimeout As Long) _ As Long #End If Sub btnMsgbox() Call MsgBoxTimeout(0, "اللهم صلى على سيدنا محمد", "منتدى أوفيسنا", vbInformation, 0, 4000) Call Test End Sub Sub Test() Application.OnTime Now + TimeValue("00:10:00"), "btnMsgbox" End Sub رسالة الصلاة على سيدنا محمد 2.xlsm

اذا كان هناك شيتين منفصلين فلابد ومن الأفضل عمل المعادلات بهذا الكود ويتم وضع هذا الكود فى الملف المراد وضع المعادلة به ,بعد الضغط على Alt F11 ثم فتح مديول جديد ولصق هذا الكود به وربطه بزر كما فى الملف المرسل لك Sub ToList() Dim finalrow As Long Dim wsd As Workbook Dim wsl As Workbook Dim wsdd As Worksheet Dim wsll As Worksheet 'Open Book with database Set wsd = Workbooks.Open("C:\Users\Ali Mohamed\Desktop\Next.xlsx")'لابد من تغيير عنوان الملف هذا لما هو فى كمبيوترك 'Copy using Index and match to worksheet Set wsll = ThisWorkbook.Worksheets("Sheet1") With wsll.Range("g2") < 0 wsll.Range("g2").Formula = "=INDEX([Next.xlsx]Sheet1!$B$2:$B$5000,MATCH(A2,[Next.xlsx]Sheet1!$A$2:$A$5000,0))" 'Copy row down based on first cell where formula is place finalrow = wsll.Cells(Rows.Count, 1).End(xlUp).Row wsll.Range("g2").AutoFill Destination:=wsll.Range("g2:g" & finalrow) End With 'Activate sheet where formula is placed wsll.Activate wsll.Cells(1, 1).Activate End Sub أما فى حالة نفس الملف بصفحتين مختلفين فالأمر لا يحتاج سوى معادلة Index & Match عادية ولا يحتاج الأمر الى كود =IFERROR(INDEX(Sheet1!$B:$B,MATCH(A2,Sheet1!$A:$A,0)),"")

نزولا عن رغبة الاحبة بتزويده ببرنامج محاسبة شركات شامل اضع بين ايديكم هذا العمل المتواضع User Name : admin Password : 1 أي رقم سري يواجهكم خلال استخدام البرنامج استعمل 12345 أي سؤال ان اجاهز Accounting Prog.rar

السلام عليكم ورحمة الله وبركاتة هذا مثال يتم من خلاله ربط الجداول برمجيا بدون تدخل من المستخدم عند فتح قاعدة الواجهات kaser906 يتم ربط الجداول بقاعدة جداول kaser906_be والقاعدة الثانية kasr9062 وكلتا القاعدتين مغفلتين برقم سري 1234 ضع المجلد في أي مكان او غير أسم المجلد وفتح قاعدة بيانات الواجهات kaser906 ستجد أن ربط الجداول تم بدون تدخل منك ::بالتوفيق للجميع :: TablLinkind.rar

السلام عليكم ورحمة الله وبركاته أتقدم بالشكر الجزيل لكل من في هذا المنتدى المبارك على ما قدموه لنا من معلومات طيبة ومباركة أثمرت هذا الملف الذي يعد كنز لكل مسلم أسأل الله أن يثيبنا جميعاً على هذا الجهد . ومن وجد أي فائدة ممكن تضاف للملف أو أي لمسة فنية فلا تبخلوا علينا بذلك ولكم مني وافر الشكر والتقدير . لمعلمي القرآن الكريم لحفاظ القرآن الكريم لمن أراد أن يلحق بركب أهل القرآن ويحفظ الكتاب الكريم برنامج معين لحفظ وتثبيت القرآن الكريم بعد اذن حضرتك تم رفع الحماية عن الملف لإكتمال الإستفادة للجميع وهذا هو الملف برنامج_معين_لحفظ_وتثبيت_القرآن_الكريم.rar

D1.accdb كل الطرق تودي الى روما

كلنا تلاميذ ومازلنا نتعلم أخي أبو @ ابوآمنة شكرا لك الحمد لله ::بالتوفيق::

أ @kaser906 بارك الله فيك الآن حلت المشكلة بفضل الله ثم بمجهودكم ومتابعتكم جزاكم الله خيرا وسامحني إذ اتعبتك معي أ @ابوآمنة الشكر موصول لكم ولكل ما يفيد بعلم ويتعامل بحلم

كل المحبة والاحترام

جرب الخيار كما بالصورة

شكرا على إطرائك @qathi

جرب غير نوع الخط بالمتصفح

تم وضع مثال على الرابط التالي

اشكرك على المرور يا غالي العلم لا يحتكر

استاذنا / @عبد اللطيف سلوم ابو اشرف جزاك الله خيرا تنسيق جميل ماشاء الله جعله الله في ميزان حسناتك كثيرا من الاخوان سوف يستفيدون منه ومن افكاره

انا عندي مافي اي مشكله للعلم انا استخدم اوفيس عربي 2010

فهمت قصدك وهذا أخر تعديل وأرجو أن يكون هو المطلوب أخر تعديل.rar

تم ضبط الملف وتم الإرسال

أهلا بك في المنتدى-تفضل طالما انك لم تقم برفع ملف مدعوم بشرح كافى ووافى ,يمكنك رؤية هذا الفيديو https://www.youtube.com/watch?v=E2MVMaskbJs

لماذا تصعب على نفسك ؟!!!! ولما لا تضع هاتين الصفحتين فى ملف واحد بدل من ملفين ؟! عموماً تفضل لك ما طلبت Basic.xlsm Next.xlsx

تفضل أخي محمد بعد تعديل بيانات اضغط على زر "حفظ بيانات" في اسفل النموذج BK .accdb

بعد اذن استاذى الجليل ومعلمى القدير ووالدى الحبيب الاستاذ المبجل استاذ @jjafferr هذه النسخه المحموله من البرنامج وبضاعتكم ترد اليكم لو تتذكر يا معلمى موضوعكم الشيق احمل ملفاتك الهامة بقاعدة البيانات 1- عند الفتح للقاعدة للمرة الاولى يتم الاتى انشاء مجلد رئيسى بمسار القاعدة باسم Program Files بتم داخله انشاء مجلد باسم Utility يحتوى على 1- zint.exe برنامج منشئ الباركود 2-Commandline.txt الاوامر الخاصة بمنشئ الباركود 3-manual.txt دليل الاستخدام 4-QR_&_Barcode_Reader_(Pro)_2.2.4-P.apk برنامج ماسح الاكواد للجوالات التى تعمل بنظام الاندرويد نسخة كاملة ومحدثه يتم كذلك انشاء مجلد باسم QR images يحتوى على 1- QRCode.png صورة الباركود لهذا النوع QR Code 2- PDF417.png صورة الباركود لهذا النوع PDF 417 3- Barcode.png صورة الباركود لهذا النوع Code 128 بخصوص برنامج الجوال لنظام الاندرويد QR_&_Barcode_Reader_(Pro)_2.2.4-P.apk هذه الصور توضح الانواع التى يستطيع مسحها وقراءة بياناتها على الجوال كما ان للبرنامج مميزات رائعة QR-Code_Generator.zip

السلام عليكم ورحمة الله تعالى وبركاته استاذى الجليل ومعلمى القدير ووالدى الحبيب الاستاذ @jjafferr سلمت يمينك على هذه الهدية القيمة الرجاء تثبيت الموضوع مرة اخرى بقسم الاكسس واسمحوا لى ان اهديكم هذا التطبيق الاكثر من رائع تطبيق pro qr barcode scanner.apk للاندرويد QR_Scanner-v2.1.9-P.zip

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

جزاك الله كل خير أستاذ مجدى ورحم الله والديك

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

وذلك بعد استبدال كودك بهذا الكود Option Explicit '//////////////////////////////////////////////////////////////////// 'Password masked inputbox 'Allows you to hide characters entered in a VBA Inputbox. ' 'Code written by Daniel Klann 'March 2003 '//////////////////////////////////////////////////////////////////// 'API functions to be used Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 Private hHook As Long Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim RetVal Dim strClassName As String, lngBuffer As Long If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lParam End Function Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _ Optional YPos, Optional HelpFile, Optional Context) As String Dim lngModHwnd As Long, lngThreadID As Long lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook End Function 'Hope someone can use it! Sub TEST() Dim strAdminPWord As String strAdminPWord = InputBoxDK("Password required to proceed.", "Enter Licence Code") If strAdminPWord = "123" Then MsgBox "cool Password Correct ", vbOKOnly, "success" Else MsgBox ("You entered an invalid password") ' Exit Sub End If End Sub اخفاء باسورد تنفيذ الماكرو.xls

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

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

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

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

السلا عليكم ورحمة الله وبركاته شهر مبارك وكل عام وانتم بخير كود لتحويل المعادلات الى قيم Option Explicit Sub Kh_Formula_To_Value() Dim MyCalcu As XlCalculation With Application MyCalcu = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With '===================================== '////////////////////////////////////// '===================================== ' هنا تضع النطاق والمعادلة التي تريد تحويلها قيم ' Formula_To_Value باستخدام '===================================== ' T هنا المعادلة اللي في العمود Formula_To_Value Range("T5:T30"), "=RC[-2]*RC[-1]" ' x هنا المعادلة اللي في العمود ' مثل عمل كود الاخ كيماس Formula_To_Value Range("X5:X30"), "=IF(COUNTIF(RC16:R30C16,RC16)=1,SUMPRODUCT((R5C16:R1500C16=RC16)*(R5C20:R1500C20)),"""")" ' Y هنا المعادلة اللي في العمود Formula_To_Value Range("Y5:Y30"), "=SUMPRODUCT((R5C16:R1500C16=RC16)*(R5C20:R1500C20))" '===================================== '////////////////////////////////////// '===================================== With Application .ScreenUpdating = True .Calculation = MyCalcu End With End Sub ================================================= Sub Formula_To_Value(MyRng As Range, MyFormula As Variant) With MyRng .ClearContents .Formula = MyFormula .Cells = .Value End With End Sub وهو طلب احدهم في الموضوع http://www.officena.net/ib/index.php?showtopic=37827 المرفق ملف اكسل 2003 كود تحويل المعادلات الى قيم.rar

و للتجميع هذه طريقة أخرى فعالة = نعم أستاذ بارك الله فيك الخاصية evaluate تقوم بتقييم أى معادلة يعنى لو عندك معادلة شغالة بدون مشاكل فى الشيت يمكنك تقييمها من خلال الكود باستخدام evaluate و تقييمها معناه حسابها و إرجاع قيمتها النهائية " القيمة و ليس المعادلة كما شاهدت فى ملفك بشرط ألا تزيد حروفها على 255 حرفا أيضا لا نضع علامة "=" معها هكذا Range("x5") = Application.Evaluate("SUMPRODUCT((P5:P1500=P5)*(T5:T1500))" و هذه الخاصية مشابهة لخاصية calculate = هذا المطلوب بسطر واحد من الكود وبدون أن تظهر المعادلة أصلا فى الخلية درة غالية لكن ما تغلى عليكم كل عام أنتم بخير أخى ضع السطر التالى فى حدث نقر الزر Range("x5") = Application.Evaluate("SUMPRODUCT((P5:P1500=P5)*(T5:T1500))") كما يمكنك استخدام دالة sum هكذا Range("x5") = Application.Evaluate("SUM((P5:P1500=p5)*T5:T1500)") رابط المشاركة