أبو ليمونه

السلام عليكم شباب حاولت اضع الكود ادناه في الاكسل عندي لكن ما قدرت ... يطلع بدل الكلمات العربية ؟؟؟؟؟؟ علامات استفهام ... مالحل ؟؟ الاكسل واجهة انجليزية 2013 الويندز واجهة انجليزية 7 ويكتب عربي اتمنى تفيديوني ... Public Function Monitize(num_entry) Dim LE Dim PT Dim iVal Dim fFrac Dim cDigit Dim cFrac Dim result LE = " جنيه " PT = " قرش " iVal = Int(num_entry) cDigit = Digit_Translator(iVal) fFrac = Val(Right(Format(num_entry, "000000000000.00"), 2)) cFrac = Digit_Translator(fFrac) If cDigit <> "" And fFrac > 0 Then result = cDigit & LE & " و " & cFrac & PT If cDigit <> "" And fFrac = 0 Then result = cDigit & LE If cDigit = "" And fFrac <> 0 Then result = cFrac & PT Monitize = result End Function Private Function Digit_Translator(X) Dim n Dim c Dim c1 Dim Digit1 Dim c2 Dim Digit2 Dim c3 Dim Digit3 Dim c4 Dim Digit4 Dim c5 Dim Digit5 Dim c6 Dim Digit6 n = Int(X) c = Format(n, "000000000000") c1 = Val(Mid(c, 12, 1)) Select Case c1 Case Is = 1: Digit1 = "واحد" Case Is = 2: Digit1 = "اثنان" Case Is = 3: Digit1 = "ثلاث" Case Is = 4: Digit1 = "اربع" Case Is = 5: Digit1 = "خمس" Case Is = 6: Digit1 = "ست" Case Is = 7: Digit1 = "سبع" Case Is = 8: Digit1 = "ثمان" Case Is = 9: Digit1 = "تسع" End Select c2 = Val(Mid(c, 11, 1)) Select Case c2 Case Is = 1: Digit2 = "عشر" Case Is = 2: Digit2 = "عشرون" Case Is = 3: Digit2 = "ثلاثون" Case Is = 4: Digit2 = "اربعون" Case Is = 5: Digit2 = "خمسون" Case Is = 6: Digit2 = "ستون" Case Is = 7: Digit2 = "سبعون" Case Is = 8: Digit2 = "ثمانون" Case Is = 9: Digit2 = "تسعون" End Select If Digit1 <> "" And c2 > 1 Then Digit2 = Digit1 + " و" + Digit2 If Digit2 = "" Then Digit2 = Digit1 If c1 = 0 And c2 = 1 Then Digit2 = Digit2 + "ة" If c1 = 1 And c2 = 1 Then Digit2 = "احدى عشر" If c1 = 2 And c2 = 1 Then Digit2 = "اثنتى عشر" If c1 > 2 And c2 = 1 Then Digit2 = Digit1 + " " + Digit2 c3 = Val(Mid(c, 10, 1)) Select Case c3 Case Is = 1: Digit3 = "مائة" Case Is = 2: Digit3 = "مئتان" Case Is > 2: Digit3 = Left(Digit_Translator(c3), Len(Digit_Translator(c3))) + "مائة" End Select If Digit3 <> "" And Digit2 <> "" Then Digit3 = Digit3 + " و" + Digit2 If Digit3 = "" Then Digit3 = Digit2 c4 = Val(Mid(c, 7, 3)) Select Case c4 Case Is = 1: Digit4 = "الف" Case Is = 2: Digit4 = "الفان" Case 3 To 10: Digit4 = Digit_Translator(c4) + " آلاف" Case Is > 10: Digit4 = Digit_Translator(c4) + " الف" End Select If Digit4 <> "" And Digit3 <> "" Then Digit4 = Digit4 + " و" + Digit3 If Digit4 = "" Then Digit4 = Digit3 c5 = Val(Mid(c, 4, 3)) Select Case c5 Case Is = 1: Digit5 = "مليون" Case Is = 2: Digit5 = "مليونان" Case 3 To 10: Digit5 = Digit_Translator(c5) + " ملايين" Case Is > 10: Digit5 = Digit_Translator(c5) + " مليونا" End Select If Digit5 <> "" And Digit4 <> "" Then Digit5 = Digit5 + " و" + Digit4 If Digit5 = "" Then Digit5 = Digit4 c6 = Val(Mid(c, 1, 3)) Select Case c6 Case Is = 1: Digit6 = "مليار" Case Is = 2: Digit6 = "ملياران" Case Is > 2: Digit6 = Digit_Translator(c6) + " مليارات" End Select If Digit6 <> "" And Digit5 <> "" Then Digit6 = Digit6 + " و" + Digit5 If Digit6 = "" Then Digit6 = Digit5 Digit_Translator = Digit6 End Function

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

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

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

السلام عليكم ... شباب اتمنى منكم مشاركتي ارائكم .... ماهي افضل طريقة لاستخراج نتائج المعادلات اعلاه ... جربت اطبق المعادلات اعلاه على خلايا اكثر ... لكن الاكسل يعلق ... رئيكم ماهي افضل طريقة ؟ ... شكرا لكم

السلام عليكم ... حاولت تحويل دالة SUMIFS الى VBA لكن وجدت انه من الصعب تحويلها ... لاني اعرف فقط اساسيات VBA ولم اتعمق فيها ... لدي دالتين : الدالة الاولى وهي : =SUMIFS(Data1!$D$1:$D$50000, Data1!$A$1:$A$50000, $B$1, Data1!$B$1:$B$50000, "<="&A2, Data1!$C$1:$C$50000, "T") وتم تطبيق هذه الدالة على الخلايا B2:E100 والدالة هذه الثاني هي : =SUMIFS(Data2!$D$1:$D$50000, Data2!$A$1:$A$50000, $B$1, Data2!$B$1:$B$50000, "<="&A101, Data2!$C$1:$C$50000, "T")+$B$100 وتم تطبيق هذه الدالة على الخلايا B101:E199 سؤالي ... هل بالامكان تحويل الداتين اعلاها الى كود VBA يعطي نفس النتيجية ويكون مرن وسريع باستخراج النتيجة المطلوبة ؟؟ ... او هل بالامكان تحويل الدالتين الى PowerPivot او Power Query حيث انني اتعامل مع كم هائل من البيانات ... حيث ان الداتا بيز احيانا قد تحتوي على 150000 صف مرفق لكم مثال ملف اكسل ... شاكرا ومقدرا لكم مساعدتكم ... Ex.xlsx.zip

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

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

السلام عليكم ... شباب عندي كود vba ينسخ الخلية من B1:B100 ويلصقها في C1:C100 اذا الخلية a = 1 كل دقيقة : Sub Moodi() If Sheet1.Range("A1").Value = 1 Then Sheet1.Range("A30:Y500").Copy Sheet1.Range("A31").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Range("A1").Select End If Application.OnTime Now + TimeSerial(0, 1, 0), "Moodi" End Sub ما اريد عمله هو ان يقوم بالعملية ذاتها دون استخدام الذاكرة clipboard لانني اقوم بمهام اخرى من نسخ ولصق في برنامج اخر ... ايضا اريده ان يعمل في الخلفية ... فلو قمت بفتح شيت جديدة بنفس الملف او ملف اكسل اخر ... لا يتاثر ... وانما يستمر بعمله دون توقف ... شكرا لكم على مساعدتكم ...

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

هلا فيك ابو نصار اللهم بارك فيه وارزقه من خيرات الدنيا والاخرة وادخله فسيح جناتك الكود جميل جدا وكل يوم اتعلم شي جديد منك سؤال بعد الاخير انا قرأت ان API timer دقيق جدا بالتعامل مع الجزأ بالثانية هل بالامكان تعديل الكود الى API timer Option Explicit Private Declare Function SetTimer Lib "user32" _ (ByVal hWnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" _ (ByVal hWnd As Long, _ ByVal nIDEvent As Long) As Long Private m_TimerID As Long 'Note: The duration is measured in milliseconds. ' 1,000 milliseconds = 1 second Public Sub StartTimer(ByVal Duration As Long) 'If the timer isn't already running, start it. If m_TimerID = 0 Then If Duration > 0 Then m_TimerID = SetTimer(0, 0, Duration, AddressOf TimerEvent) If m_TimerID = 0 Then MsgBox "Timer initialization failed!" End If Else MsgBox "The duration must be greater than zero." End If Else MsgBox "Timer already started." End If End Sub Public Sub StopTimer() 'If the timer is already running, shut it off. If m_TimerID <> 0 Then KillTimer 0, m_TimerID m_TimerID = 0 Else MsgBox "Timer is not active." End If End Sub Public Property Get TimerIsActive() As Boolean 'A non-zero timer ID indicates that it's turned on. TimerIsActive = (m_TimerID <> 0) End Property Private Sub TimerEvent() Debug.Print "Timer event fired: "; Format$(Now, "long time") End Sub تحياتي لك

هلا فيك ابونصار صراحة انت مبدع دالة TimeSerial تعمل بكل مرونه الله يعطيك الف عافية سؤال اخير هل بالامكان ان اضع بدل الرقم 0.5 الخليه A1 حيث ان الخليه A1 تساوي 0.5 Private Const H_Scond As Single = A1 تحياتي لك

ابو نصار شكرا لك الكود يعمل لكن احس انه غير دقيق دالة TimeToRun = Now + TimeValue("00:00:01") / 2 تعمل بمرونه ودقة كل نص ثانية هل هناك كود يعمل بدقه بدون ان يتجمد ملف الاكسل كل ثلث ثانية مثلا؟ تحياتي لك واستفدت منك كثيرا جزيت كل خير

هلا فيك ابو نصار راح اتعبك معاي الان الثانية فيها 1000 جزأ من الثانية هل استطيع تعديل الكود ليعمل كل 800 او كل 700 جزأ من الثانية حاولت اقسمه على 1.5 او 1.7 بس شكل VBA مايقبل كسور تحياتي لك

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

السلام عليكم لدي ملف اكسل مربوط بشكل دنماكي ببرنامج خارجي مثبت على جهازي لجلب بعض الارقام البرنامج اسمه Kannumber.exe الخلايا من A1 الى B5 يوجد بها روابط لهذا البرنامج مثال خليه A1 يوجد بها : KannumberDde|DSREFER.REFER!BESTSELLER~99284= خليه B2 يوجد بها : KannumberDde|DSREFER.REFER!PRODUCTNUMBER~55678= سؤالي : انا استخدم كود VBA يعمل كل ثانية ليقوم بعض الحسابات وهو : Sub ScheduleCopyPriceOver() Application.Calculation = xlCalculationManual TimeToRun = Now + TimeValue("00:00:01") Application.OnTime TimeToRun, "CopyPriceOver" Application.Calculation = xlCalculationAutomatic End Sub هل استطيع تعديله ليقوم بتحديث جميع الخلايا التي تحتوي على روابط خارجية كل ثانية؟ انا استطيع انا اقوم بذلك يدويا عبر Data> Refresh All ولكن اريد VBA يقوم بذلك كل ثانية شكرا لمساعدتكم

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

السلام عليكم لدي كود يعمل كل ثانية هل بالامكان ان اجعله يعمل كل نص ثانية (ملي بالثانية millisecond) ؟ Model Sub ScheduleCopyPriceOver() Application.Calculation = xlCalculationManual TimeToRun = Now + TimeValue("00:00:01") Application.OnTime TimeToRun, "CopyPriceOver" Application.Calculation = xlCalculationAutomatic End Sub ThisWorkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.OnTime TimeToRun, "CopyPriceOver", , False End Sub Private Sub Workbook_Open() DTime = Time Call ScheduleCopyPriceOver End Sub تحياتي لكم

السلام عليكم شباب ابحث عن معادلة تقرب الرقم الى رقمين انا احددهم انا حددت الرقمين في الخليه A1 والخليه A2 والرقم المطلوب تقريبه في الخليه A3 والناتج في الخليه A4 نفترض اننا حددنا في الخليه A1 الرقم 80 وحددنا في الخليه A2 الرقم 40 وادخلنا في الخليه A3 الرقم 65 النتيجة في الخلية A4 يجب ان تكون 80 لان الرقم 65 هو اقرب الى 80 و ابعد عن 40 وبالتالي لو افترضنا ان الرقم في الخليه A3 هو 55 يجب ان يكون الناتج في الخليه A4 الرقم 40 لان رقم 55 اقرب الى 40 وابعد عن الـ 80 ولو افترضنا ان الرقم في الخليه A3 هو 60 يقوم بتقريبه الى الحد الاصغر وهو 40 لان الرقم 60 ليس قريب من 80 ولا 40 وانما هو بالوسط هل هناك معادلة تقوم بهذا الغرض؟ اتمنى ان اجد منكم المساعده وتقبلوا مني فائق الاحترام

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

السلام عليكم احتاج الى مساعدتكم بتعديل الكود التالي : Sub CopyPriceOver() If Range("A1").Value > Range("B1").Value Then Sheet1.Range("A1").Copy Sheet1.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Calculate Calculate ElseIf Range("A1").Value < Range("C1").Value Then Sheet1.Range("A1").Copy Sheet1.Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Calculate Calculate End If Call ScheduleCopyPriceOver End Sub ما اريد عمله هو التالي اذا القيمة في الخلية A1 اكبر من القيمة في الخلية B1 فيقوم بنسخ القيمة من A1 الى B1 و اذا القيمة في الخلية A1 اصغر من القيمة في الخلية C1 فيقوم بنسخ القيمة من A1 الى C1 خلية A1 خلية متغيرة فالغرض من الكود هو استخراج اعلى قيمة سجلتها الخلية A1 واستخراج اصغر قيمة سجلتها الخلية A1 اريد الكود ان يقوم بتطبيق العملية على الخلايا A1:A100 فينظر بكل خلية من A1 الى A100 اذا اي خلية في A اكبر من الخلية B يقوم بنسخها الى B واذا اي خلية في A اصغر من الخلية C يقوم بنسخها الى C مثال للتوضيح فقط: نفترض ان الخلية A79 اكبر من الخلية B79 فيجب ان يقوم الكود بنسخ A79 الى B79 نفترض ان الخلية A88 اصغر من الخلية C88 يقوم بنسخ خلية A88 الى الخلية C88 نفترض ان الخلية A45 اصغر من الخلية B45 لا يقوم بالنسخ ولا بمسح الخلية B45 لانها اصغر من A45 وليست اكبر نفترض ان الخلية A99 تساوي B99 او C99 لا يقوم بعمل شي ولا يمسح B99 و C99 ياليت اجد منكم المساعدة ولكم مني جزيل الشكر Test.zip

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

استاذ عبدالله تحية طيبة ... بحثت بالانترنت ووجدت الكود المطلوب لكن يجتاج الى تطوير .... التطوير المطلوب : 1- الكود لا يبحث الا بالكلمات الانجليزية ... وانا سوف استخدمه بالكلمات العربية والارقام 2- الكود يبحث بجميع موقع الانترنت وانا اريده ان يبحث بموقع واحد فقط 3- الكود يتجاهل تاريخ اخر تحديث للموضوع وانا اريد فقط المواضيع المطروحة اخر اسبوع. 4- النتيجة المعطاه بخلية B1 على سبيل المثال هي = About 4,510,000,000 results وانا اريد النتيجة تظهر بدون كلمة About وكلمة results اريد فقط الرقم لاستطيع استخدمه بمسائل حسابية 5- عندما استخدم الكود لـ 200 كلمة تظهر رسالة خطا بمعنى اخر (اذا كتبت كلمات من الخلية A1 الى الخلية A200 ثم شغلت الكود) يعطي رسالة خطا واحيانا يهنق هل بالامكان مساعدتي بتطوير الكود المرفق؟ ولكم مني جزيل الشكر والامتنان .... اخوكم محمد test.zip

استاذ عبدالله تحية طيبة ... للاسف .... حينما افتح البرنامج تطلع لي رسالة تقول ادخل كلمة البحث ... انا اريد ان اكون مخول لكتابة كلمتين في خلية A1 وخلية B1 ومن ثم احصل على فقط على عدد النتائج في الخلية C1 لا اريد فتح المتصفح ...ولا اريد ان انظر الى النتائج ... مايهمني هو فقط عدد النتائج تحياتي لك

تحية طيبة للجميع نفترض ان الخلية A1 تحتوي على كلمة = العولمة والخلية B1 تحتوي على كلمة = التطور الخلية C1 هي النتيجية والمفترض ان تكون = 408 (الرقم هذا هو عدد النتائج خلال محرك بحث قوقل) https://www.google.com.sa/search?hl=ar&as_q=&as_epq=&as_oq=%D8%A7%D9%84%D8%B9%D9%88%D9%84%D9%85%D8%A9+%D8%A7%D9%84%D8%AA%D8%B7%D9%88%D8%B1&as_eq=&as_nlo=&as_nhi=&lr=&cr=&as_qdr=w&as_sitesearch=http%3A%2F%2Fwww.alriyadh.com%2F&as_occt=any&safe=images&as_filetype=&as_rights= المطلوب: اذا كتبت كلمة في A1 وكلمة في B1 يتم البحث في قوقول كالتالي (بحث متقدم): 1- البحث عن اي من الكلمات المكتوبة في A1 او B1 2- البحث عن الصفحات التي تم تحديثها خلال الفترة الزمنية (اسبوع) 3- البحث فقط بموقع http://www.alriyadh.com/ ياليت احد يساعدني بكتابة كود VBA منتظر مساعدتكم تحياتي لكم