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

السلام عليكم كما عودناكم عى كل جديد فقد قمت بتصميم برنامج خاص بمحلات الجوالات لصديق لي من المملكة العربية السعودية اضع البرنامج بين ايديكم وهو مفتوح المصدر لكي تستفيدو منه الرقم السري لاكواد فيجوال بيسك 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)),"")

السلام عليكم 🙂 اللغة العربية هي المطلوبة هنا 🙂 المرفق المضغوط فيه مجلد وبرنامج اكسس ، والبرنامج اللي يعمل لنا QR code الموجود على الرابط التالي: https://sourceforge.net/projects/zint/ ويتم حفظ الصورة هنا Data > QR_images وعلشان كل شيء يشتغل تمام ، رجاء لا تعمل تغيير في مكان الملفات ولا المجلدات ، ولا تغيير اسمائها (طبعا تقدر تعمل اللي تريد ، بس على اساسه يجب تغيير الكود كذلك) وهي النتيجة: وخلونا نشوف من يقدر يقرأ الصورة 🙂 ----------------------------------------------------------------------------- إضافة في يوم الثلاثاء 7 / 5 / 2019 : عملت مثال يعمل على 2003 🙂 ----------------------------------------------------------------------------- إضافة في يوم الجمعة 14 / 6 / 2019 : باركود بطاقة دخول الطائرة (Boarding card) وهي من نوع PDF417 اختار الحقول اللي تريدها تظهر في QR code بإختيار مربع صح/خطأ : . والنتيجة: . و باركود 128 (ويمكن عمل اي نوع من انواع الباركود) . والتقرير (وبعد اذن اخي محمد سلامه ، فقد استعملت الصورة التي استعملها في مثاله 🙂 ) . وبهذه الطريقة نرى اننا لا نحتاج ان نحفظ صورة لكل سجل (واذا اردنا ذلك ، فنعمل تعديل في الكود ليقوم بذلك). وهذا الكود مضافا اليه عمل الباركود العادي : Private Sub Make_QR_Barcode() ' 'https://sourceforge.net/projects/zint/ ' If Len(Me.str_Text & "") = 0 Then Exit Sub Dim App_Name As String Dim Output_File As String Dim Output_Text As String Dim Encoding As String Dim Command_Line As String App_Name = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) Output_Text = Chr(34) & Me.str_Text & Chr(34) 'QR code Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "QR_code.png" & Chr(34) Command_Line = App_Name & " -o " & Output_File & " --rotate=0 --eci=24 --scale=2 -w 10 --height=100 --barcode=58 -d " & Output_Text 'Debug.Print Command_Line Shell_n_Wait Command_Line, vbHide 'Barcode 128 Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "Barcode.png" & Chr(34) Command_Line = App_Name & " -o " & Output_File & " --rotate=0 -d " & Me.ID 'Debug.Print Command_Line Shell_n_Wait Command_Line, vbHide 'PDF 417 Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "PDF_417.png" & Chr(34) Command_Line = App_Name & " -o " & Output_File & " --rotate=0 --eci=24 --binary --barcode=55 --mode=3 -d " & Output_Text 'Debug.Print Command_Line Shell_n_Wait Command_Line, vbHide End Sub ----------------------------------------------------------------------------- إضافة في يوم الجمعة 22 / 6 / 2019 : تم عمل VCard QR ليخزن معلومات الشخص مباشرة في الموبايل 🙂 . وبإستخدام برامج الموبايل والتي تقرأ QR Code ، يمكنك حفظ معلومات VCard QR مباشرة في عناوين الموبايل 🙂 البرنامج zint الموجود في المرفق ، فيه امكانية عمل عدة انواع من QR والباركودات ، ولكن كل نوع من هذه الانواع له صيغة خاصة في عمله ، فمثلا كود VCArd QR هو: Function Add_Items() Dim VCard_Text As String 'clear field VCard_Text = "" VCard_Text = "BEGIN:VCARD" & vbCrLf VCard_Text = VCard_Text & "VERSION:3.0" & vbCrLf VCard_Text = VCard_Text & "N:" & Me.[Family Name] & ";" & Me.[Given Name] & ";" & Me.[Additional Name] & ";" & Me.[Name Prefix] & ";" & vbCrLf VCard_Text = VCard_Text & "FN:" & Me![Name] & vbCrLf VCard_Text = VCard_Text & "ORG:" & Me.[Organization 1] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 1 - Type] & ",VOICE:" & Me.[Phone 1 - Value] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 2 - Type] & ",VOICE:" & Me.[Phone 2 - Value] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 3 - Type] & ",VOICE:" & Me.[Phone 3 - Value] & vbCrLf VCard_Text = VCard_Text & "ADR;:" & ";;" & Me.[Address 1] & ";;;;" & vbCrLf VCard_Text = VCard_Text & "BDAY:" & Me.[Birthday] & vbCrLf VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 1 - Type] & ":" & Me.[E-mail 1 - Value] & vbCrLf VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 2 - Type] & ":" & Me.[E-mail 2 - Value] & vbCrLf VCard_Text = VCard_Text & "NOTE:" & Me.Notes & vbCrLf VCard_Text = VCard_Text & "URL:" & Me.[Website 1] & vbCrLf VCard_Text = VCard_Text & "END:VCARD" Add_Items = VCard_Text End Function والذي يختلف عن PDF417 والذي يختلف عن غيره. المرفق في ملفين بصيغة txt والذي فيهما جميع الاوامر التي يمكن استعمالها لعمل مختلف انواع الباركود 🙂 ----------------------------------------------------------------------------- إضافة في يوم السبت 2 / 11 / 2019 : هنا مثال لعمل بطاقة عمل ID.zip ، بأصغر حجم QR code (رجاء ابقاء حجمه ، فقد توصلت الى هذا الحجم والكود بعد محاولات ساعات طويلة) : . وهذا هو QR code . اما تفاصيل عمل البطاقات ، فهذا الرابط فيه تفاصيل كاملة: . جعفر ملاحظة: 1. المرفق في هذه المشاركة هو البرنامج الاخير ، وفيه جميع التعديلات التي في بقية المشاركات. 2. الـ api التي تنتظر إنتهاء الامر ، ثم تنتقل للسطر التالي في الكود اسمها ShellWait ، هذه لا تتعامل مع Unicode / utf-8 / ومنها الحروف العربية بطريقة صحيحة : http://access.mvps.org/access/api/api0004.htm بينما هذه تمام : https://github.com/xxdoc/vb6-Shell-Wait/blob/master/Shell %26 Wait v2/modShellWait.bas zint QR 3.zip ID.zip Shell_n_Wait_2021-12-13.txt.zip

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

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

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

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

لايوجد مشكلة تفضل غيرنا موقع شرط حقل البحث فقط D2.accdb

من نوع الاوفيس الاصدارات الحديثة

جميل استاذ عبداللطيف الله يعطيك العافية

جرب المرفق 55.accdb

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

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

بارك الله فيك أخي @kaser906 هذا الابداع بذاته

جرب هذا .... لأن المشكلة غير موجودة عندي فلذلك لا استطاع التجربة ... Application.FollowHyperlink "http://www.google.com/search?q= " & Me.title.Value & ""

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

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

عمل مبارك ورائع أخي وصديقي عبداللطيف وإلى الأمام

وعليكم السلام بارك الله فيك استاذ عبداللطيف شغل جميل -عاشت ايدك

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

من خصائص مربع النص طبق هذه الخصائص :::::: محاذاة النص ............. توزيع اتجاه القراءة ............. اليمين لليسار الهامش الايسر .......... 1 سم الهامش العلوي ........ 0.199 سم الهامش الايمن ......... 1 سم الهامش السفلي ....... 0.199 سم تباعد الاسطر .......... 1 سم

بارك الله فيك

هذه تعتبر معادلة وتقرأ وترأى ما يتم إدخاله فلا يمكن تعديلها ولكن ماذا تقصد لو تم وضع درجة في عمود التحريرى فهو بالفعل يكون به درجة ؟!!!!!! لا افهمك يمكنك التوضيح أكثر على الملف ولكن عموما المعادلات لا ترى هذا

تفضل بالطبع بعد اذن استاذنا سليم نموذج.xlsx

وذلك بعد استبدال كودك بهذا الكود 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

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

السلام عليكم ورحمة اله استخدم هذا الكود Sub DelRows() Dim x As Integer, i As Long, y As Long y = Sheet1.Range("A" & Rows.Count).End(xlUp).Row For i = y To 2 Step -1 x = WorksheetFunction.Days360(Cells(i, "A"), Date) If x < 45 Then Cells(i, "A").EntireRow.Delete End If Next End Sub

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

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

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

السلا عليكم ورحمة الله وبركاته شهر مبارك وكل عام وانتم بخير كود لتحويل المعادلات الى قيم 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

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