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

بسم الله الرحمن الرحيم احبتي الكرام السلام عليكم ورحمة الله وبركاته وبعد : وجدت لكم دالة تأخذ التاريخ والوقت الدولي من الانترنت ، مع شروحات للاكواد وافية كثير من الاخوة يحتاجون هذه الدالة خاصة الذين يعتمدون على جهاز واحد ، وذلك من اجل سد ثغرات احتمال التلاعب بوقت وتاريخ الجهاز من الشروط وجود خدمة الانترنت ، واعتقد في اليوم الحاضر اصبح من الضروريات التي لا يتصور الاستغناء عنها هذه الدالة جميلة جدا تجلب التاريخ والوقت الدولي مع امكانية مراعاة فارق التوقيت حول العالم الدالة : InternetTime()' التاريخ والوقت في جرينتش InternetTime(3)' في مكة المكرمة InternetTime(2)' في مصر امكانية عمل التنسيقات عليه بالضبط تماما كما نتعامل مع الدالة()Date أو ()NOW فهذا التنسيق يعطينا الوقت في مكة Format(InternetTime(3);"hh:mm:ss AM/PM") وكما تلاحظون ان الارقام التي بين الاقواس تعني فارق الزمن وهذه هي الوحدات النمطية : Function InternetTime(Optional GMTDifference As Integer) As Date '----------------------------------------------------------------------------------- 'This function returns the Greenwich Mean Time retrieved from an internet server. 'You can use the optional argument GMTDifference in order to add (or subtract) 'an hour from the GMT time. For Example if you call the function as: '=InternetTIme(2) it will return the (local) hour GMT + 2. Note that the 'GMTDifference variable is an integer number. 'Written by: Christos Samaras 'Date: 25/09/2013 'Last Updated: 20/11/2013 'e-mail: xristos.samaras@gmail.com 'site: http://www.myengineeringworld.net 'Declaring the necessary variables. Dim Request As Object Dim ServerURL As String Dim Results As String Dim NetDate As String Dim NetTime As Date Dim LocalDate As Date Dim LocalTime As Date 'Check if the time difference is within the accepted range. If GMTDifference < -12 Or GMTDifference > 14 Then Exit Function End If 'The server address. ServerURL = "http://www.timeanddate.com/worldclock/fullscreen.html?n=2" 'Build the XMLHTTP object and check if was created successfully. On Error Resume Next Set Request = CreateObject("Microsoft.XMLHTTP") If Err.Number <> 0 Then Exit Function End If On Error GoTo 0 'Create the request. Request.Open "GET", ServerURL, False, "", "" 'Send the request to the internet server. Request.Send 'Based on the status node result, proceed accordingly. If Request.readyState = 4 Then 'If the request succeed, the following line will return 'something like this: Mon, 30 Sep 2013 18:33:23 GMT. Results = Request.getResponseHeader("date") 'Use the Mid function to get something like: 30 Sep 2013 18:33:23. Results = Mid(Results, 6, Len(Results) - 9) 'Use the Left and Right function to distinguish the date and time. NetDate = Left(Results, Len(Results) - 9) '30 Sep 2013 NetTime = Right(Results, 8) '18:33:23 'Convert the date into a valid Excel date 30 Sep 2013 -> 30/9/2013. 'Required for countries that have some non-Latin characters at their alphabet (Greece, Russia, Serbia etc.). LocalDate = ConvertDate(NetDate) 'Add the hour difference to the retrieved GMT time. LocalTime = NetTime + GMTDifference / 24 'Return the local date and time. InternetTime = LocalDate + LocalTime End If 'Release the XMLHTTP object. Set Request = Nothing End Function Function ConvertDate(strDate As String) As Date '------------------------------------------------------------------------- 'This function converts the input date into a valid Excel date. 'For example the 30 Sep 2013 becomes 30/9/2013. 'Required for countries that have non-Latin characters at their alphabet. 'Written by: Christos Samaras 'Date: 25/09/2013 'e-mail: xristos.samaras@gmail.com 'site: http://www.myengineeringworld.net '------------------------------------------------------------------------- 'Declaring the necessary variables. Dim MyMonth As Integer 'Check the month and convert it to number. Select Case UCase(Mid(strDate, 4, 3)) Case "JAN": MyMonth = 1 Case "FEB": MyMonth = 2 Case "MAR": MyMonth = 3 Case "APR": MyMonth = 4 Case "MAY": MyMonth = 5 Case "JUN": MyMonth = 6 Case "JUL": MyMonth = 7 Case "AUG": MyMonth = 8 Case "SEP": MyMonth = 9 Case "OCT": MyMonth = 10 Case "NOV": MyMonth = 11 Case "DEC": MyMonth = 12 End Select 'Rebuild the date. ConvertDate = DateValue(Right(strDate, 4) & "/" & MyMonth & "/" & Left(strDate, 2)) End Function وتطبيق المقال بهذا المثال : db2.rar

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

الإجابة عن السؤال الأول Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim Last As Integer, Qn As String If Target.Column = 8 And Target.Row > 3 And Target <> "" Then Cancel = True Last = Cells(Rows.Count, 1).End(xlUp).Row + 1 Qn = InputBox("أدخل الكمية", "الكمية") If Not IsNumeric(Qn) Then Exit Sub With Cells(Last, 1) .Value = Last - 8: .Offset(, 1).Value = Target.Offset(, 1).Value .Offset(, 2).Value = Val(Qn): .Offset(, 3).Value = Target.Offset(, 2).Value .Offset(, 4).Value = Val(Qn) * Target.Offset(, 2).Value: .Offset(1, 3).Value = "ÇáÅÌãÇáí" .Offset(1, 4).Value = WorksheetFunction.Sum(Range("E9:E" & Last )) End With With Range(Cells(Last, 1), Cells(Last, 5)) .Borders.Value = 1: .Borders.ColorIndex = 48 End With End If End Sub

السلام عليكم اخي الكريم اليك الحل db3.rar

بارك الله فيك يا أخي : سليم والله لقد وسّعَ الله بك ضيّقا شكرا على صبرك معي أخوك: أحمد أبو محمد

عظمة على عظمة.. أستاذي أبوحنين.. ويكأنك بتقول لي ليه تبيع مويه في حارة السقايين.. تُشكر على هذا العمل الرائع. أما بالنسبة لي فقد أنجزتها بالكود التالي: Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("h4:h25")) Is Nothing Then r = 9 Sum = 0 Do While Cells(r, 1) <> "" Sum = Sum + Cells(r, 5) r = r + 1 Loop On Error GoTo ErrorHandler qty = InputBox(Prompt:=" ÃÏÎá ÇáßãíÉ ÇáÎÇÕÉ È " & Target.Offset(0, 1).Value, Title:="ÅÏÇÑÉ ÇáãÊÌÑ", Default:=1) If Not IsNumeric(qty) Then Exit Sub Cells(r, 1) = Cells(r - 1, 1) + 1 Cells(r, 2) = Target.Offset(0, 1).Value Cells(r, 3) = qty Cells(r, 4) = Target.Offset(0, 2).Value Cells(r, 5) = Cells(r, 3) * Cells(r, 4) End If Cells(r - 1, 1).Select Range(ActiveCell, ActiveCell.End(xlToRight)).Borders.LineStyle = xlNone Cells(r, 1).Select Range(ActiveCell, ActiveCell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlThin Range(ActiveCell, ActiveCell.End(xlToRight)).Offset(2, 0).Interior.Color = xlNone Cells(r + 1, 3).Font.Color = vbBlack Cells(r + 1, 3) = "" Cells(r + 1, 4) = "ÇáÅÌãÇáí" Cells(r + 1, 5) = Sum + Cells(r, 5) Range(ActiveCell, ActiveCell.End(xlToRight)).Offset(3, 0).Interior.Color = RGB(15, 36, 62) Cells(r + 3, 3) = "ÔßÑÇð áÊÓæÞßã" Cells(r + 3, 3).Font.Color = vbWhite shadding Exit Sub ErrorHandler: Cells(r, 1) = 1 Resume Next End Sub Sub shadding() Dim i As Integer i = 10 Do i = i + 1 Loop Until Cells(i, 1).Value = "" i = i - 1 If Cells(10, 1).Value = "" Then Exit Sub Else Dim Col As Long Dim Row As Long For Col = 1 To 5 For Row = 10 To i Step 2 Sheet1.Cells(Row, Col).Interior.Color = RGB(200, 200, 200) Next Row Next Col End If End Sub

و عليكم السلام أخي انسخ الكود كما هو و ألصقه في ورقة العمل و لا تنسي ان تغير إسم الفورم KH_T_SEARSH حسب الفورم التي أنشأتها

أبو حنــــين اخى الفاضل جزاك الله خيرا ما شاء الله عليك و تم التنفيذ و تم زيادة العمود J Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Union(Range("A2:A20000"), Range("F2:F20000", Range("J2:J20000")))) Is Nothing Then Cancel = True KH_T_SEARSH.Show End If End Sub و شكرا morestudy تحياتى ضعه فى حدث ورقة العمل و مرفق مثال من هنا كود مميز جاهز_كود دبل كليك لاستدعاء اى فورم ...الخ تحياتى

الكود يصبح بهذا الشكل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Union(Range("A2:A20000"), Range("F2:F20000"))) Is Nothing Then Cancel = True KH_T_SEARSH.Show End If End Sub هناك جزئية ناقصة و هذا التصحيح If Not Intersect(Target, Union(Range("A2:A20000"), Range("F2:F20000"), Range("J2:J20000"))) Is Nothing Then

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة DATA --- LIST --- CREAT LIST تم ارفاق كود الحل من الفاضل ا / أبوعبد الله مرفق الملف CREATE LIST.rar و لا تنسونا من صالح الدعاء تحياتى

شوف بعض تعديلات بسيطة Aziz (1).rar

جرب هذ الملف protect non empty data with Pass word.rar

saadeps اخى الفاضل جزاك الله خيرا

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

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

اخي الكريم انا نفذت الشرط نسبة الى طلبك في البداية لكن هنا اختلف الطلب تفضل التعديل اخي الكريم Moad2.rar

جرب هذا الملف oumr.rar

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

تفضل اخي الكريم مثال بسيط Moad1.rar

السلام عليكم جزاكم الله خيرا اخي الكريم ياسر ائراءا للموضوع بدون استخدام معادلات على الخلايا Sub kh_Start() Dim obj Dim Lr As Integer, iRnd As Integer, i As Integer Lr = Cells(Rows.Count, "A").End(xlUp).Row - 1 '======================================== Set obj = CreateObject("Scripting.Dictionary") '======================================== Do iRnd = Int((Rnd * Lr) + 1) If Not obj.Exists(iRnd) Then i = i + 1 obj.Add iRnd, i Range("F2").Cells(i, 1).Resize(1, 2).Value = Range("A2").Cells(iRnd, 1).Resize(1, 2).Value End If If i = 10 Then Exit Do Loop Set obj = Nothing End Sub المرفق 2003 Random word Generator2.rar

الأخ الحبيب الغالي مختار .. مين اللي في بالك .. اللي في بالك ربنا يهنيه يا سيدي إليك الملف المرفق (بس متنساش لو عجبك الحل يختاره كأفضل إجابة) Random Word Generator.rar

السلام عليكم ورحمة الله وبركاته لهذا المنتدى أفضال كثيره علي شخصياً في تعلم الأمور الكثيره في الأكسيل وأخص بالذكر الأستاذ القدير ( محمد طاهر ) والذي لا يتردد في تقديم المساعده واليوم أقدم لكم هديه متواضعه بها كل ما تعلمته من المنتدى الجميل وأتمنى أن تنال رضاكم وتحقق الفائده . * صمم البرنامج على Microsoft Excel XP * إذا كان خيار الأمان الخاص بالماكرو لديك في الوضع متوسط أو مرتفع فستظهر لك رساله تسئلك قبل التشغيل هل تريد ( تمكين وحدات الماكرو ) أم لا ..؟ بالطبع أختر ( تمكين وحدات ماكرو ) وهذا لكي يتمكن البرنامج من تنفيذ الأوامر المطلوبه منه * إذا أردت أن لا تظهر هذه الرساله لديك مرة أخرى ويتم التشغيل مباشرة أذهب الي ( أدوات - ماكرو - أمان ) وأختار ( منخفض ) فلا تظهر لك الرساله من جديد . * البرنامج يتم التسجيل فيه بشكل شهري وعليك فقط أختيار الشهر والسنه من صفحة الأصناف وسوف تظهر تلقائياً بباقي الصفحات * هناك خيار لمسح كافة البيانات بشكل سهل وبسيط ولكن للمزيد من التأكيد تم وضع صفحه مخصصه لذلك تحتاج فيها لأدخال كلمة السر ثم الضغط على( نعم ) للمسح أو( لا ) للتراجع * كلمة السر للمسح هي ( بسم الله ) * يمكنك أدخال مبلغ ( كحد صرف ) شهري وسوف يقوم البرنامج بحساب الفرق بين المبلغ وبين المصروف ويظهر لك النتيجه في صفحة مستقله * هناك صفحه يظهر بها المصروف الكلي ومصروف كل بند على حده ويمكنك البحث عن الصنف المراد بطريقتين ( الأولى ) بالأسم ... والثانيه ( برقم الصنف ) * لا تقلق من مسح البيانات فالبرنامج محمي لكي لا تتضررالمعادلات والأوامر الهامه به * حجم البرنامج مضغوط ( 447 كيلو بايت ) بعد فك الضغط ( 2.40 ميجابايت ) تفضل بتحميل البرنامج أضغط هنـــــــــا وفقنا الله واياكم لما يحب ويرضى .