الـعيدروس

السلام عليكم جزاك الله كل خير استاذ عبدالله

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

السلام عليكم جرب المرفق على السريع ارجو التجربه اذا به اي ملاحظات اطرحها ولن اتأخر ان شاء الله تم تعديل المرفق برنامج_مقهى_1.rar

اخي محبوب7 اولاً اذهب الى قائمة خيارات إكسل ثم حفظ باإسم واحفظ الملف باأحد امتدادت الماكرو أو "Ctrl" + "S" اذا الاوفيس الذي تستخدمة 2007 حدد من قائمة حفظ كنوع وإختار التالي Excel Macro-Enabled Workbook وحدد موقع حفظ الملف وإن شاء الله سيعمل معك اي ماكرو

السلام عليكم اضفظ التالي في حدث الفورم Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox "إستخدم زر خروج", vbCritical, "" Cancel = True End If End Sub

جربت ويعمل بشكل طبيعي

استخدم مرجع الورقة بدلاً من المسمى لمعرفة مرجع الورقة النشطه Sub An_Sheet() MsgBox ActiveSheet.CodeName End Sub Sub Ali_Rn() ' Sheet1'مثلا مرج الورقة هو Set Rng = Sheet1.Range("b16:b30") End Sub وعند تغير مسمى الورقة لايلزم تغيره من الكود لان مرجع الورقة ثابت

السلام عليكم بهذه الطريقة مثلا معادلة "E47" =IF($C47="";"";IF(ISERROR(SUMIF($G$2:$BR$2;"مدين";G47:BR47));"";SUMIF($G$2:$BR$2;"مدين";G47:BR47))) ومعادلة "G47" =IF(ISERROR(SUMPRODUCT((GL_Name_2012=G$1)*(Date_2012=$B47)*(Movement!$F$2:$F$1998=$C47)*Dr._2012)<>0);"";SUMPRODUCT((GL_Name_2012=G$1)*(Date_2012=$B47)*(Movement!$F$2:$F$1998=$C47)*Dr._2012))

اي تكست بوكس ؟ هل تقصد مربع الإختيار اذا مربع الاختيار الذي تقصد ماهو الشرط البحث اي رقم يبداء بالرقم المعطى او مطابق للقيمه فقط ؟ استبدل السطر التالي If Application.WorksheetFunction.Search(M, q, 1) = 1 And _ IIf(CheckBox1, q.Text = q.Offset(0, -6).Text & "/" & Mm Or q.Text) Then بهذا If Application.WorksheetFunction.Search(M, q, 1) = 1 And _ q.Offset(0, -6).Text & "/" & Mm Or q.Text Then

السلام عليكم Public Sub A_Last() Dim A_Lst As Range Dim A_Num& ' المدى المراد تحديد اخر خليه ليس بها بيانات Set Rn = ActiveSheet.Range("B32:D57") With Rn Set A_Lst = .Cells(.Rows.Count, "B").End(xlUp) A_Num = A_Lst.Row + 1 Cells(A_Num, 2).Select End With End Sub

الكود كالتالي ' اسم الملف الإفتراضي المراد Private Const إسم_الملف_الإفتراضي As String = "اعدادي.xls" ' مسمى المودويل المدرج فيه الماكرو Private Const المودويل As String = "Module1" ' الماكرو المراد حذفه اذا تغير مسمى الملف الإفتراضي Private Const مسمى_الماكرو As String = "Name2" Sub auto_open() On Error Resume Next If ThisWorkbook.Name <> إسم_الملف_الإفتراضي Then Set V_C = ActiveWorkbook.VBProject.VBComponents(المودويل).CodeModule If Err.Number <> 0 Then MsgBox ("المودويل : " & المودويل & vbCr & "غير موجود في الملف الحالي") Exit Sub End If S_l = V_C.ProcStartLine(مسمى_الماكرو, vbext_pk_Proc) If Err.Number <> 0 Then MsgBox ("الماكرو " & "Sub " & مسمى_الماكرو & "( )" & vbCr _ & المودويل & " : غير موجود في.") Else MsgBox "بسبب تغير اسم الملف" & مسمى_الماكرو & "تم حذف ماكرو", vbInformation, "" End If With V_C Num_l = .ProcCountLines(مسمى_الماكرو, vbext_pk_Proc) .DeleteLines StartLine:=S_l, Count:=Num_l End With Else End If End Sub عند تغير مسمى الملف اول وفتح الملف اول تجربه سيحذف الماكرو وعند فتح الملف مره اخرى سيظهر لك رسالة ان الماكرو غير موجود كذا تم الحذف وبالاماكن بعدها الاستغناء عن رسائل التنبيه عموما انا غيرت لك اسم الملف في المرفق من اعدادي الى اعدادي1 وعملت لك نسخه من الكود في Module2 جرب المرفق وابلغنى بالنتائج اعدادي1.rar

اضافة اخر الى حل اخي الفاضل قنديل الصياد الصق الكود في حدث الورقة Private Sub Worksheet_SelectionChange(ByVal T As Excel.Range) Set my_r = Range("B1:B" & Cells(Rows.Count, 1).End(xlUp).Row) If Not Intersect(T, my_r) Is Nothing Then T.Offset(0, -1).Select End Sub

تعديل بسيط لملف الاستاذ القدير بن عليه ترك الشرط للمستخدم ------------------ تحديد مربع الاختيار بحث حسب القيمة - القيمة المطابقه ------------------ الغاء تحديد مربع الاختيار بحث عن اي قيمة تبدء بالرقم المعطى Nadia_Offic8_a.rar

ارفق الملف وسيتم تطبيق الكود عليه او نسخه منه فارغه لكي اعرف امتداد الملف والتسمية

هل غيرت الثوابت التاليه اسم الملف "Ali_x" و الامتداد للملف الذي تعمل عليه "xls" او "xlsm" غير في الثابت حسب ملفك ' اسم الملف الإفتراضي المراد Private Const إسم_الملف_الإفتراضي As String = "Ali_x.xls" ومكان الماكرو في اي مودويل "Module1" او "Module2" Private Const المودويل As String = "Module1"

السلام عليكم هذا الكود في مودويل Sub auto_open() Dim Sh As Worksheet Set Sh = ActiveSheet Select Case Sh.Name ' الأوراق المراد حسابها اتوماتك Case Is = "Sheet2", "Sheet3" Tr_Ali True ' والاوراق الاخر يدوي Case Else Tr_Ali False End Select End Sub Private Function Tr_Ali(Bn As Boolean) With Application .Calculation = IIf(Bn, -4105, -4135) .CalculateBeforeSave = Bn End With End Function Sub تفعيل_الحساب_تلقائي() Tr_Ali True End Sub وهذا الكود في حدث Thisworkbook Private Sub Workbook_SheetActivate(ByVal Sh As Object) Call auto_open End Sub في حال ادرت تفعيل الحساب تلقائي "Alt" + "F8" و شغل الكود "تفعيل_الحساب_تلقائي" ارجو التجربه

السلام عليكم كما تفضل الاخ الكريم عبدالسلام زاوي عنوان الموضوع غير دال على محتواه بخصوص طلبك بالامكان عمل حل اخر وهيا ورقة الدرجات تستخدم كقاعدة بيانات تضيف فيها الاسماء والدرجات وعندما تريد عمل صفحات بيكون عن طريق كود يقوم بنسخ البيانات من ورقة الدرجات الى ورقة جديدة ويعمل صف للاجماليات كل 24 صف بيكون عدد الصفوف في الصفحه الواحده 24 صف كعدد ثابت والصف الـ 25 يسجل فيه الاجمالي وعرض الصف بيكون 1 cm كعرض ثابت للصف وبعدها يتم تقسيم الصفحات كل 25 سطر صفحه --------------------- اما تثبيت صف كااجمالي من المستحيل بالاكسل هذا مالدي من معرفه بالاكسل بهذا الخصوص انتظر ردك

من خيارات الاكسل ثم خيارات الحساب حساب المصنف حفز الخيار يدوي والغي التحفيز من على مربع إعادة حساب المصنف قبل الحفظ ثم احفظ وهكذا يصير الحساب يدوي ويتفعل اذا اردت بكود مثلاً ؟ هل هذا ماتريد

لااعلم ان كانت الجدولة كالتالي بتفيدك السبت احمد محمد 6 صباحا الى 2 ظهراً السبت ادريس اديب 2 صباحا الى 10 ليلاً السبت ماهر منير 10 ليلاً الى 10 صباحاً الاحد احمد محمد 6 صباحا الى 2 ظهراً الاحد ادريس اديب 2 ظهراً الى 10 ليلاً الاحد ماهر منير 10 ليلاً الى 6 صباحاً الاثنين احمد محمد 6 صباحا الى 2 ظهراً الاثنين ادريس اديب 2 ظهراً الى 10 ليلاً الاثنين ماهر منير 10 ليلاً الى 6 صباحاً الثلاثاء احمد محمد 6 صباحا الى 2 ظهراً الثلاثاء ادريس اديب 2 ظهراً الى 10 ليلاً الثلاثاء ماهر منير 10 ليلاً الى 6 صباحاً الاربعاء احمد محمد 6 صباحا الى 2 ظهراً الاربعاء ادريس اديب 2 ظهراً الى 10 ليلاً الاربعاء ماهر منير 10 ليلاً الى 6 صباحاً الخميس احمد محمد 6 صباحا الى 2 ظهراً الخميس ادريس اديب 2 ظهراً الى 10 ليلاً الخميس ماهر منير 10 ليلاً الى 6 صباحاً الجمعه احمد محمد 6 صباحا الى 2 ظهراً الجمعه ادريس اديب 2 ظهراً الى 10 ليلاً الجمعه ماهر منير 10 ليلاً الى 6 صباحاً

السلام عليكم Ch = TextBox1 '----------------------------------------------- ' A'اخر صف به بيانات للعمود La = Cells(Rows.Count, 1).End(xlUp).Row 'CountIf = حساب عدد الخلايا في نطاق والتي تحقق الشرط المعطى ' النطاق = Range("A14:A" & اخر صف به بيانات) ' الشرط = Ch ' متغير لمربع النص If Application.CountIf(Range("A14:A" & La), Ch) = 1 Then MsgBox "الاسم مكرر": TextBox1 = "": TextBox1.SetFocus: Exit Sub End If تم عمل تنبية للتكرار على زر الحفظ ايضاً في المرفقات ورقه بالحصه_2.rar

السلام عليكم تفضل الكود الية الكود كالتالي : عند وصول التاريخ كما اشرت ميلادي 01/01/2014 هجري 01/01/1435 مابين الساعه 9 و 11 صباحاً عند فتح الملف يظهر رسالة تشعرك بصول التاريخ المحدد بالامكان تغير وقت التنبية بالسطر التالي من الكود Private Const الساعه = "9:11" مثلاً من 10 الى 12 Private Const الساعه = "10:12" المقصد بداية الوقت يكتب قبل : نهاية الوقت بعد : الصق الكود في مودويل '=================================== ' الوقت الإفتراضي مابين الساعه 9 و 11 ' Private Const الساعه = "9:11" Sub auto_open() Dim D, E As Date '************************** St = Split(الساعه, ":")(0) En = Split(الساعه, ":")(1) '************************** ' التاريخ الهجري '---------------------------------------------------------------------- Calendar = vbCalHijri D = DateValue(Now()) If DateSerial(Year(D), Month(D), Day(D)) = DateSerial(1435, 1, 1) Then If Hour(Now()) >= Val(St) And Hour(Now()) <= Val(En) Then MsgBox " التاريخ اليوم هجري : " & D, vbExclamation, "تنبية " End If End If '---------------------------------------------------------------------- ' التاريخ الميلادي Calendar = vbCalGreg E = DateValue(Now()) If DateSerial(Year(E), Month(E), Day(E)) = DateSerial(14, 1, 1) Then If Hour(Now()) >= Val(St) And Hour(Now()) <= Val(En) Then MsgBox " : التاريخ اليوم ميلادي : " & E, vbExclamation, "تنبية " End If End If End Sub

ارفق مثال وان شاء الله الكل لن يقصر معك

السلام عليكم تفضل المرفقات ورقه بالحصه_1.rar

السلام عليكم الكود الاخير بعد التجربه يسبب ثقل على الملف استخدم هذا التعديل الكود التالي في مودويل Const KL_NAMELENGTH = 9 Const KT_TYPE = 0 Const KT_SUBTYPE = 1 Const KT_FUNCTIONKEYS = 2 Public Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long Public Declare Function GetKeyboardType Lib "user32" (ByVal nTypeFlag As Long) As Long Public Bn As Boolean Public Function Ch_Bn() As String Dim S_nm As String S_nm = String(KL_NAMELENGTH, 0) GetKeyboardLayoutName S_nm Ern = IIf(Right(S_nm, 2) = 1, "Ar", "En") Ch_Bn = Ern End Function Sub Dir_B() Ch_Bn Select Case Ch_Bn Case Is = "Ar" Bn = True Debug.Print Bn Case Is = "En" Bn = False Debug.Print Bn End Select End Sub وهذا الكود في حدث Thisworkbook Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Set Sh = ActiveSheet If Not Intersect(Target, Sh.Range("B5:B32")) Is Nothing Then Call Dir_B If Bn = True Then SendKeys "%+" Else Call Dir_B If Bn = False Then SendKeys "%+" End If End Sub مانفست كلابشة_Ali.rar

او استخدم هذا الكود اضمن الصق الكود التالي في مودويل Public Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long والكود التالي في حدث Thisworkbook Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Set Sh = ActiveSheet If Not Intersect(Target, Sh.Range("B5:B32")) Is Nothing Then LoadKeyboardLayout "00000409", 1 Else LoadKeyboardLayout "00000401", 1 End If End Sub