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

دالة لضبط اول حرف وجعله capital title.rar

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

كود لاظهار هل الورقة محمية ام لا وهل الملف بالكامل محمى ام لا وهو على شكل معادلة نضعها فى اى خلية protected.rar

نستخد اسماء اوراق العمل كثيرا فى الاكواد والماكروهات وقد يغيرها المستخدم فيضيع كل شىء كود حماية اسماء اوراق العمل ActiveWorkbook.Protect Password:="MyPassword", Structure:=True

اسف اخوانى هناك خطأ عند تجربة الكود السابق وهذا تصحيحه Dim aTabOrd As Variant Dim iTab As Long Dim nTab As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) If IsEmpty(aTabOrd) Then aTabOrd = Array("D1", "U1", "AG1", "E3", "E6", "E7", "E8", "E9", "C10", "Q10", _ "D11", "Q11", "D12", "Y6", "Y7", "Y8", "Y9", "W10", "AK10", "X11", "AK11", "X12", _ "E13", "Q13", "Z13", "AG13", "D14", "Q14", "AG14", "F15", "O15", "AA15", "AI15", _ "E16", "M16", "S16", "AA16", "AI16", "C17", "G17", "N17", "D18", "E19", "C20", "E21", _ "G22", "P22", "F23", "A24", "A25", "A26", "A27", "A28", "A29", "AD19", "S20", "U20", "AD20", _ "S21", "U21", "AD21", "S22", "U22", "AD22", "S23", "U23", "AD23", "S24", "U24", "AD24", "S25", _ "U25", "AD25", "S27", "U27", "AD27", "S28", "U28", "AD28", "S29", "U29", "AD29", "AI32", _ "AF35", "C31", "L31", "C32", "N32", "F34", "D35", "G36", "G37", "D38", "F50", "T40", "AI40", _ "AI42", "AI43", "AI44", "AI45", "AI47", "AI48", "AI49", "AI50") nTab = UBound(aTabOrd) + 1 iTab = 0 Else iTab = (iTab + 1) Mod nTab End If Application.EnableEvents = False Range(aTabOrd(iTab)).Select Application.EnableEvents = True End Sub

شكرا لك اخى عل التشجيع

شكرا لك اخى عبد الله كود اخر اكثر تحكما فى موضوع التنقل بين الخلايا Private Sub Worksheet_Open(ByVal Target As Range) Dim aTabOrd As Variant Dim i As Long 'ضع ترتيب الخلايا للتنقل بينها aTabOrd = Array("D1", "U1", "AG1", "E3", "E6", "E7", "E8", "E9", "C10", "Q10", _ "D11", "Q11", "D12", "Y6", "Y7", "Y8", "Y9", "W10", "AK10", "X11", "AK11", "X12", _ "E13", "Q13", "Z13", "AG13", "D14", "Q14", "AG14", "F15", "O15", "AA15", "AI15", _ "E16", "M16", "S16", "AA16", "AI16", "C17", "G17", "N17", "D18", "E19", "C20", "E21", _ "G22", "P22", "F23", "A24", "A25", "A26", "A27", "A28", "A29", "AD19", "S20", "U20", "AD20", _ "S21", "U21", "AD21", "S22", "U22", "AD22", "S23", "U23", "AD23", "S24", "U24", "AD24", "S25", _ "U25", "AD25", "S27", "U27", "AD27", "S28", "U28", "AD28", "S29", "U29", "AD29", "AI32", _ "AF35", "C31", "L31", "C32", "N32", "F34", "D35", "G36", "G37", "D38", "F50", "T40", "AI40", _ "AI42", "AI43", "AI44", "AI45", "AI47", "AI48", "AI49", "AI50") 'Loop through the array of cell address For i = LBound(aTabOrd) To UBound(aTabOrd) 'لو تغيرت خلية فى النطاق المعرف سابقا If aTabOrd(i) = Target.Address(0, 0) Then 'لو الخلية التى تغيرت هى اخر خلية If i = UBound(aTabOrd) Then 'اختر اول خلية فى النطاق Me.Range(aTabOrd(LBound(aTabOrd))).Select Else 'اختر الخلية التالية (مندى اوفيسسنا) Me.Range(aTabOrd(i + 1)).Select End If End If Next i End Sub تم التصحيح فى المشاركة رقم 10

عندما تقوم بحماية ااورقة تترك للمستخدم بعض الخلايا القليلة فقط الغير محمية وذلك للادخال ولكن التنقل يكون على كل الخلايا هذا كود للتنقل عبر خلايا محددة فقط Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$C$10" Then Range("D5").Select If Target.Address = "$D$10" Then Range("E5").Select Application.EnableEvents = True End Sub

كود حماية الخلايا بعد الادخال Private Sub Worksheet_Change(ByVal Target As Range) Dim MyRange As Range Set MyRange = Intersect(Range("A1:D100"), Target) If Not MyRange Is Nothing Then Sheets("Sheet1").Unprotect password:="hello" MyRange.Locked = True Sheets("Sheet1").Protect password:="hello" End If End Sub

نستخدم جميعا فى بعض الاحيان شيتات واحد لكل شهر كود انشاء هذه الشيتات فى اى ملف عمل Sub officenaDoMonths() Dim J As Integer Dim K As Integer Dim sMo(12) As String sMo(1) = "يناير" sMo(2) = "فبراير" sMo(3) = "مارس" sMo(4) = "ابريل" sMo(5) = "مايو" sMo(6) = "يونيو" sMo(7) = "يوليو" sMo(8) = "اغسطس" sMo(9) = "سبتمبر" sMo(10) = "اكتوبر" sMo(11) = "نوفمبر" sMo(12) = "ديسمبر" For J = 1 To 12 If J <= Sheets.Count Then If Left(Sheets(J).Name, 5) = "Sheet" Then Sheets(J).Name = sMo(J) Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sMo(J) End If Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sMo(J) End If Next J For J = 1 To 12 If Sheets(J).Name <> sMo(J) Then For K = J + 1 To Sheets.Count If Sheets(K).Name = sMo(J) Then Sheets(K).Move Before:=Sheets(J) End If Next K End If Next J Sheets(1).Activate End Sub

كود لماكرو تغير ارتفاع الصفوف المحددة For Each r In ActiveWindow.RangeSelection.Rows r.RowHeight = 36 Next r

طريقتين لحذف جميع البيانات بدون المعادلات لطريقة الاولى اضغط F5 يظهر الشكل التالى اختر SPECIAL ليظهر الشكل التالى اختر CONSTANts وتاكد ان علامات الصح تحت FORMULAS موجودة بالكامل ثم اضغط على OK ثم DEL من الكيبورد الطريقة الثانية عن طريق هذا الكود Sub ClearAllButFormulas() Dim wks As Worksheet For Each wks In Worksheets 'iلتفادى الخطأ فى حالة وجود معادلات فقط On Error Resume Next wks.Cells.SpecialCells _ (xlCellTypeConstants, 23).ClearContents On Error GoTo 0 Next Set wks = Nothing End Sub كود لتكبير الخلية النشطة فقط المرفقات : Book1.rar 9.95K 27 عدد مرات التحميل كود جعل الاكسيل نسخة demo بوقت محدد Sub Auto_Open() Dim exdate As Date exdate = "04/30/2011" If Date > exdate Then MsgBox ("لقد استخدمت البرنامج للمدة القصوى =منتدى اوفيسنا") ActiveWorkbook.Close End If MsgBox ("تبقى لك " & exdate - Date & "Days left") End Sub ماكرو للوصول لخلية الادخال الجديدة باختصار كيبورد ماكرو للوصول لخلية الادخال الجديدة باختصار كيبورد كل ما عليك الضغط على ctrl+j او اى اختصار تحدده او وضع زر المرفقات : Book1.rar 9.23K 14 تجميع لاختصارات الكيبورد المرفقات : ExcelShortcuts_all.rar 7.45K 20 عدد مرات التحميل كود لمنع ادخال اكثر من عدد معين من الحروف كود لمنع ادخال اكثر من عدد معين من الحروف Private Sub Worksheet_SelectionChange(ByVal Target As Range) For Each cell In UsedRange 'تدخل عدد الاحرف بعد علامة < If Len(cell.Value) > 15 Then MsgBox " عدد الاحرف اكثر من المسموح به __منتدى اوفيسنا___" cell.Value = "" End If Next End Sub وثمة كود أكثر صرامة للتحقق في معالج الأحداث لمعرفة ما إذا كان إجراء التغيير في مكان ما ضمن مجموعة من الخلايا التي تحتاج إلى أن تكون ارقام محدودة. بامكانية تحيديد المدر وليس كل الشيت Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim rng As Range Dim rCell As Range Dim iChars As Integer On Error GoTo ErrHandler 'Change these as desired 'لكتابة عدد الاحرف iChars = 15 'لكتابة المدى المراد استخدامه (منتدى اوفيسنا) Set rng = Me.Range("A1:A10") If Not Intersect(Target, rng) Is Nothing Then Application.EnableEvents = False For Each rCell In Intersect(Target, rng) If Len(rCell.Value) > iChars Then rCell.Value = Left(rCell.Value, iChars) MsgBox rCell.Address & " has more than" _ & iChars & " characters." & vbCrLf _ & "It has been truncated." End If Next End If ExitHandler: Application.EnableEvents = True Set rCell = Nothing Set rng = Nothing Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub يصعب الوصول الى او مسح الاسماء التى لم يعد لها اى استخدام مع هذا البرنامج التحكم سهل جداً منقول من منتدى اجنبى المرفقات : [*] namemanager2007.zip 950.63K 4 عدد مرات التحميل كود لمسح اسماء المدى الغير مستخدمة Sub RidOfNames() Dim myName As Name Dim fdMsg As String On Error Resume Next fdMsg = "" For Each myName In Names If Cells.Find(What:=myName.Name, _ After:=ActiveCell, _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False).Activate = False Then fdMsg = fdMsg & myName.Name & vbCr ActiveWorkbook.Names(myName.Name).Delete End If Next myName If fdMsg = "" Then MsgBox "لايوجد اسماء فى هذا المصنف---- منتدى اوفيسنا-----" Else MsgBox "Names Deleted:" & vbCr & fdMsg End If End Sub

شكرا على الردود الجميلة بارك الله لكم

بارك الله فيكم يكفى تقديركم وكلماتكم الرقيقة شكرا لكم ولادارة المنتدى

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

اخشى انى لم افهم السؤال اخى هل من الممكن التوضيح اكثر

شكرا على ردك اخى وبارك الله لك

اشكرك جدا اخى رجب واشكر الادارة على الترقية التى لم الاحظها الا عند قراءة ردك الكريم

وهل استطيع ان اعدل على استاذ بالطبع كلام حضرتك صح

كود لتكبير الخلية النشطة فقط Book1.rar

ماكرو للوصول لخلية الادخال الجديدة باختصار كيبورد كل ما عليك الضغط على ctrl+j او اى اختصار تحدده او وضع زر Book1.rar

كود جعل الاكسيل نسخة demo بوقت محدد Sub Auto_Open() Dim exdate As Date exdate = "04/30/2011" If Date > exdate Then MsgBox ("لقد استخدمت البرنامج للمدة القصوى =منتدى اوفيسنا") ActiveWorkbook.Close End If MsgBox ("تبقى لك " & exdate - Date & "Days left") End Sub بالطبع يوضع فى حدث فتح ال workbook

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

وثمة كود أكثر صرامة للتحقق في معالج الأحداث لمعرفة ما إذا كان إجراء التغيير في مكان ما ضمن مجموعة من الخلايا التي تحتاج إلى أن تكون ارقام محدودة. بامكانية تحيديد المدر وليس كل الشيت Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim rng As Range Dim rCell As Range Dim iChars As Integer On Error GoTo ErrHandler 'Change these as desired 'لكتابة عدد الاحرف iChars = 15 'لكتابة المدى المراد استخدامه (منتدى اوفيسنا) Set rng = Me.Range("A1:A10") If Not Intersect(Target, rng) Is Nothing Then Application.EnableEvents = False For Each rCell In Intersect(Target, rng) If Len(rCell.Value) > iChars Then rCell.Value = Left(rCell.Value, iChars) MsgBox rCell.Address & " has more than" _ & iChars & " characters." & vbCrLf _ & "It has been truncated." End If Next End If ExitHandler: Application.EnableEvents = True Set rCell = Nothing Set rng = Nothing Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub

كود لمنع ادخال اكثر من عدد معين من الحروف Private Sub Worksheet_SelectionChange(ByVal Target As Range) For Each cell In UsedRange 'تدخل عدد الاحرف بعد علامة < If Len(cell.Value) > 15 Then MsgBox " عدد الاحرف اكثر من المسموح به __منتدى اوفيسنا___" cell.Value = "" End If Next End Sub