محمد مصطفى ابو حمزة

ممكن ترفق ملف

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

بعد اذن الاساتذة تم حل المطلوب الثالث فتح ملف من زر دون المطالبة بكلمة المرور.rar

كود حفظ نسخة احتياطية فى نفس الفولدر نسخة.rar

لعرض رسالة فى شريط الحالة لمدى معينة Sub StatusBarExample() Application.ScreenUpdating = False ' turns off screen updating Application.DisplayStatusBar = True ' makes sure that the statusbar is visible Application.StatusBar = "انتظر قليلا منتدى اوفيسنا..." ' add some code for task 1 that replaces the next sentence Application.Wait Now + TimeValue("00:00:02") Application.StatusBar = " انتظر قليلا منتدى اوفيسنا....." ' add some code for task 2 that replaces the next sentence Application.Wait Now + TimeValue("00:00:02") Application.StatusBar = False ' gives control of the statusbar back to the programme End Sub

كود لصناعة عد تنازلى فى شريط الحالة ممكن وضعه فى بداية كود طويل او عند التحديث فى ملف بطىء Sub CountDown() Dim intCounter As Integer Dim bln As Boolean bln = Application.DisplayStatusBar Application.DisplayStatusBar = True For intCounter = 30 To 1 Step -1 Application.StatusBar = intCounter & " Seconds..." Application.Wait Now + TimeSerial(0, 0, 1) Next intCounter Application.StatusBar = False Application.DisplayStatusBar = bln End Sub

كود ينسخ المدى المستخدم من كل اوراق العمل الى ورقم عمل جديدة الماكرو الاول نسخ عادى والثانى نسخ قيم فقط Sub CopyUsedRange() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long If SheetExists("Master") = True Then MsgBox "The sheet Master already exist" Exit Sub End If Application.ScreenUpdating = False Set DestSh = Worksheets.Add DestSh.Name = "Master" For Each sh In ThisWorkbook.Worksheets If sh.Name <> DestSh.Name Then If sh.UsedRange.Count > 1 Then Last = LastRow(DestSh) sh.UsedRange.Copy DestSh.Cells(Last + 1, 1) End If End If Next Application.ScreenUpdating = True End Sub Sub CopyUsedRangeValues() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long If SheetExists("Master") = True Then MsgBox "The sheet Master already exist" Exit Sub End If Application.ScreenUpdating = False Set DestSh = Worksheets.Add DestSh.Name = "Master" For Each sh In ThisWorkbook.Worksheets If sh.Name <> DestSh.Name Then If sh.UsedRange.Count > 1 Then Last = LastRow(DestSh) With sh.UsedRange DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _ .Columns.Count).Value = .Value End With End If End If Next Application.ScreenUpdating = True End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Lastcol(sh As Worksheet) On Error Resume Next Lastcol = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 End Function Function SheetExists(SName As String, _ Optional ByVal WB As Workbook) As Boolean On Error Resume Next If WB Is Nothing Then Set WB = ThisWorkbook SheetExists = CBool(Len(Sheets(SName).Name)) End Function

كود الذهاب الى خلية معينة عن طريق ادخالها فى رسالة Sub GetRange() Dim Rng As Range On Error Resume Next Set Rng = Application.InputBox(prompt:="Enter range",Type:=8) If Rng Is Nothing Then MsgBox "Operation Cancelled" Else Rng.Select End If End Sub

برنامج للفلترة المتقدمة سهل جدا وامكنانيات عديدة متوافق مع 2003 و 2007 EasyFilter 2.01.zip

شكرا على الردود واخى عيد مصطفى مازلت احاول على طلبك

شكرا لك معلمنا واستاذى الفاضل عبقرى طول عمرك

جرب هذا انا شغال بيه فى شركتى ونتائجه جيدة جدا مخازن.rar

جرب المرفق تم تطبيق الكود على المدى a1:a100 غيره كما تشاء ويتم حذف الذائد بدلا من جعل الخلية فارغة جرب واخبرنى Desktop_2.rar

كود روعة اخى طارق ويمكن الاستفادة منه لتجميد اى دالة رائع جزاك الله خيرا

جزاكم الله خيرا اساتذتى واخوانى

شكر خاص للاستاذ العيدروس على اثراءه الموضوع باكواده المتميزة

شكر خاص للاستاذ عبدالله على اثراءه الموضوع

جرب المرفق اخى بعد اذن اخى عبد الله Desktop.rar

اخى ساحاول فى ما طلبت

شرف ان ذكر عالى المقام خبور خير اسمى شاكراً لك استاذى شكرا لك اخى

شكرا لكم اخوتى على الرد المُشجع

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

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

قائمة بالدوال الجديدة فى 2007 http://blogs.office.com/b/microsoft-excel/archive/2005/10/20/formula-editing-improvements-part-3-new-functions.aspx