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

الكل يعتقد أن المعادلة يمكن أن تكون أقل من الكود فى الإمكانيات ولكن لى وجهة نظر محتلفة وهذا هو الدليل من عجائب المعادلات.rar

تفضل أخى =IF(OFFSET(C5;(COUNTA(C6:C100));0)>50;1;OFFSET(C5;(COUNTA(C6:C100));0)+1) New Microsoft Office Excel Worksheet.rar

السلام عليكم الاخ الكريم / الصّارم اعتقد ان التالي به طلبك تماماً ولكن عذرا للاطالة فالموضوع ليس موضوعي ولكنه للقدير العبقري الاستاذ القدير / جعفر طرباق .... جزاه الله خيرا بعنوان ((( كيف نجعل الملف ينتحر و يحدف نفسه من الجهاز تلقائيا ! )))) ولكني احببت ان انقله كما هو ليستفيد منه الجميع بكل طرقه واشكاله ============================================= الكود ادناه يفعل ذلك من داحل الملف نفسه و يمكن ربطه مثلا بالحدث Workbook_BeforeClose و مسح الملف تلقائيا و نهائيا و من دون اشعار المستخدم. SuicidalWorkbook.rar Option Explicit Private Const MSG_TITLE As String = "Deleting Current Workbook ..." Private Const MSG_TEXT As String = _ "You are about to permanently delete the current workbook located in :" Sub Kill_Myself() Dim lUserDecision As Long Dim sMsg As String On Error Resume Next sMsg = "Attention !" & vbNewLine & vbNewLine sMsg = sMsg & MSG_TEXT & vbNewLine sMsg = sMsg & "'" & ThisWorkbook.FullName & "'" & vbNewLine sMsg = sMsg & "from Disk!!" & vbNewLine & vbNewLine sMsg = sMsg & "Go ahead ?" & vbNewLine & vbNewLine Beep lUserDecision = _ MsgBox(sMsg, vbExclamation + vbYesNo, MSG_TITLE) With ThisWorkbook If lUserDecision = vbYes Then .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End If End With End Sub ====================================================== الكود التالي يحدف الملف بعد شهر واحد من اول استعماله تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Sub Workbook_Open() Dim lInitialDate As Long On Error Resume Next lInitialDate = Evaluate("InitialDate") If Err.Number = 13 Then Me.Names.Add "InitialDate", Date, False Me.Save End If If Date > Evaluate("InitialDate") + 30 Then Kill_Myself End Sub Private Sub Kill_Myself() .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود. ================================================================ الكود التالي يحدف الملف بعد 3 الستعمالات تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Kill_Myself End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود ========================================================= الكود التالي يحذف الملف بعد دقيقة واحدة من فتحه : (ضع الكود في ThisWorkbook Module) Option Explicit Private Const TIMEOUT As Long = 1 Private Sub Workbook_Open() Application.OnTime _ Now + TimeSerial(0, TIMEOUT, 0), Me.CodeName & ".Kill_Myself" End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ===================================================== حذف الملف ولكن باشعار المستخدم بذلك !!!! للتمكن من اشعار المستخدم و في نفس الوقت منعه تماما من اجهاض عملية حذف الملف , اقترح الكود التالي حيث يتم اشعار المستخدم بعد حذف الملف و ليس قبل : (الملف يحذف نفسه تلقائيا بعد 3 استعمالات و يشعر المستخدم بعد الحذف) Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Call NotifyUser Call Kill_Myself End If End Sub Private Sub NotifyUser() Dim sVbsFile As String sVbsFile = Environ("Temp") & "\VBS_MSG.vbs" Open sVbsFile For Output As #1 Print #1, "Dim Wb" Print #1, "On Error Resume Next" Print #1, _ "set wb=Getobject(" & Chr(34) & Me.FullName & Chr(34) & ")" Print #1, _ "MSG= ""You have exceeded the Maximum Number of uses of this file."" & vbnewline & vbnewline" Print #1, _ "MSG= msg & ""The file has been permanently deleted from your Drive !""" Print #1, "Do" Print #1, "Loop until wb.name=""""" Print #1, "WScript.Echo MSG" Close #1 Call Shell("WScript.exe " & sVbsFile) End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub وارجو من الله ان يجعل فيها افادة ... وادعو للاستاذ القدير العملاق / جعفر ... جزاه الله خيرا جزاكم الله خيرا

السلام عليكم الاخ الكريم / عمر أبو صهيب كلنا هنا لنتعلم ونعلم بعضنا البعض وكل منا يرشد الآخر للذي يعرفة فهذا ما تعلمناه من اساتذه هذا الصرح لعملاق وبالطبع علي رأس الجميع الاستاذ الخبير / عبد الله باقشير جزاك الله خيرا

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

السلام عليكم أخي العزيز ضع الكود التالي في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 2 Then Exit Sub Application.ScreenUpdating = False st = 1 If IsEmpty([B1]) Then st = [B1].End(xlDown).Row LR = [B9999].End(xlUp).Row Range("B" & st & ":B" & LR).Select Selection.Sort Key1:=Range("B" & st), Order1:=xlAscending, Header:=xlNo Range("B" & st).Select Application.ScreenUpdating = True End Sub أو تفضل الملف وبه الكود جرب أن تلغي أو تضيف أي شيء في العمود B Book1_2.rar

الاخ اشرف شكرا لك واى خدمة فعلا الحاجة ام الاختراع ومن طلب العلم سهر الليالى وعموما اليك فيديو 2 لمن ليس عنده بلوتوث

دعوة طيبة لطيب http://www.officena.net/ib/index.php?showannouncement=21&f=89 ........

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

هذا فورم للاستاذ عبدالله باقشير للادخال والتعديل والبحث http://www.officena.net/ib/index.php?showtopic=43782 قمت بتطبيقه على ملفك تحياتي data.rar

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

السلام عليكم ورحمة الله أخي الكريم يمكن ذلك بالتاكيد باختيار الخلية B2 ثم تطبق التجميد... أخوك بن علية