الـعيدروس

السلام عليكم اخي الفاضل himass اشكرك على كلامك المشجع ومالدينا نقطه في بحر امام عمالقة المنتدى الذي نتمنى من الله ان نتوصل الى ربع مالديهم من علم واما بخصوص الخط جميع ردود الموضوع هذا تظهر لدي كلها حروف بهذا الشكل ظˆظ‚ظ„ ط§ط¹ظ ولاكن عند الخروج من حسابي والدخول بدون الحساب تظهر الردود بالشكل الطبيعي ولااادري ماسبب الرد الاخير ظهر بشكل مربعات واشكرك مجددا على خلقك الكريم وكلماتك الطيبه تقبل تحياتي وشكري

السلام عليكم بالامكان الاشاره الى ملف اخر بالطريقة التاليه A1 = إسم الملف مثلا اسمه Book1.xls A2 = اسم الورقة A3 = مرجع الخلية =INDIRECT("'[" & A1 & "]" & A2 & "'!" & A3) او هكذا التسمية مباشرة ='[Book1.xls]Sheet1'!$A$3

تحط اسم الورقة هكذا مثلا اسم الورقة في A2 ومرجع الخليه في B2 =INDIRECT("'" & A2 & "'!" & B2)

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

السلام عليكم جرب المرفق امل ان يفي بالغرض واي ملاحظات أنا موجود صلاحيات المستخدمين_2.rar

السلام عليكم جرب المرفق صلاحيات المستخدمين_1.rar

������ ����� ��� ����� ��� ����� ��� ����� ������ ���� ���� ��� ��� himass ����� ��� ����� ������� ������ ��� ����� ������ ���� ��� ����� ������ ��� �� ���� ���� ��� �� Public Sub Ali_Prodc() Dim Sh As Worksheet Dim Rng As Range Ch_P On Error Resume Next With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False For Each Sh In ThisWorkbook.Worksheets If Sh.ProtectContents = True Then Sh.Unprotect Password:="123": Sh.Cells.Locked = False If Not Sh.Cells.HasFormula Then Sh.Cells.Locked = False Else Sh.Cells.FormulaHidden = True With Sh.Cells .SpecialCells(2).Locked = True .SpecialCells(-4123).Locked = True End With If Sh.Cells(1, "IV") = "True" Then Sh.Protect Password:="123" Next .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub Private Sub Ch_P() Dim Sn As Worksheet For Each Sn In ThisWorkbook.Worksheets If Sn.ProtectContents = True Then Sn.Unprotect Password:="123": Sn.Cells(1, "IV") = "True": Sn.Protect Password:="123" Next End Sub

السلام عليكم اخي إسلام حط هذا الكود في حدث Thisworkbook عند الحفظ من واجهة الإكسل أو من الإختصار "Ctrl" + "S" يفعل الكود Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Call Ali_Prodc End Sub وهذا الكود السابق وعليه تعديلات بسيطه لتلافي الأخطاء Public Sub Ali_Prodc() Dim Sh As Worksheet Dim Rng As Range Ch_P For Each Sh In ThisWorkbook.Worksheets If Sh.ProtectContents = True Then Sh.Unprotect Password:="123": Sh.Cells.Locked = False If Not Sh.Cells.HasFormula Then Sh.Cells.Locked = False Else Sh.Cells.FormulaHidden = True For Each Rng In Sh.UsedRange If Rng.Value > Empty Or Rng.HasFormula Then Rng.Locked = True Next If Sh.Cells(1, "IV") = "True" Then Sh.Protect Password:="123" Next End Sub Private Sub Ch_P() Dim Sn As Worksheet For Each Sn In ThisWorkbook.Worksheets If Sn.ProtectContents = True Then Sn.Unprotect Password:="123": Sn.Cells(1, "IV") = "True": Sn.Protect Password:="123" Next End Sub ارجو التجربه واي ملاحظات أنا موجود تحياتي

السلام عليكم شاهد المرفق صلاحيات المستخدم_A.rar

السلام عليكم اخي إسلام فعل الحماية للأوراق التي كنت عامل لها حماية ثم إستخدم الكود التالي فرضا أن رمز الحماية للأوراق هو " 123 " Public Sub Ali_Prodc() Dim Sh As Worksheet Dim Rng As Range Ch_P For Each Sh In ThisWorkbook.Worksheets If Sh.ProtectContents = True Then Sh.Unprotect Password:="123" If Not Sh.Cells.HasFormula Then Sh.Cells.Locked = False: Sh.Cells.FormulaHidden = True For Each Rng In Sh.UsedRange If Rng.Value > Empty Then Rng.Locked = True Next If Sh.Cells(1, "IV") = "True" Then Sh.Protect Password:="123" Next End Sub Private Sub Ch_P() Dim Sn As Worksheet For Each Sn In ThisWorkbook.Worksheets If Sn.ProtectContents = True Then Sn.Cells(1, "IV") = "True" Next End Sub جرب الكود وبلغنى بالنتائج

السلام عليكم تفضل المرفق تبديل المستخدم بطريقتين اما عن طريق الزر الذي في ورقة1 او إختصار تضغط زر " F3 " صلاحيات المستخدم_1.rar

السلام عليكم بالامكان عمل ذلك بحماية الورقة

السلام عليكم اخي اسلام الشيمي عذراً اخي الكريم لم انتبه لردودك بخصوص الخطاء في التعديل الاخير اضن انك استعنت بالكود الاخير بالكود السابق كاملا والتعديل على الكود المسمى Ali_Fmla_To_VBA فقط اذا عليك ان تحذف الكود المسمى Ali_Fmla_To_VBA السابق وتلصق بدلاً منه الكود بعد التعديل الأخير اذا كنت تلافيت هذه النقطه ارجو منك إرفاق الملف الذي اظهر فيه الخطاء اما مشاركتك رقم 28# لم افهم ماتقصده هل جربت الكود على ملف اخر به معادلات قليله ولم يعمل ؟ اذا لم يعمل بملف اخر غير الذي عرضته ارجو إرفاق الملف وتأكد من أنك إتبعت خطوات العمل على الكود بالشكل الصحيح كما وضحت سابقا اخي ابو تميم مرورك اسعدني اخير الكريم وجزاك الله كل خير على الدعاء ولك مثله اضعاف إن شاء الله بارك الله فيك تقبلو تحياتي وشكري

السلام عليكم اخي حماده عمر حقيقة ملاحظتك تعتبر إضافة للكود سهيت عنها حيكون التعديل في الكود كالتالي وضحت على الكود السطر الذي تم التعديل عليه Public Sub Ali_Fmla_To_VBA() Dim Sht As Worksheet Dim R As Range, Rr As Range Dim Ar_Ads(), Ar_Fm() Dim F, Lc, Prmit_A, Rw Call Ad_Refe: Call Ali_Delet: Call Ali_M Dim A Dim B Dim C Set A = ThisWorkbook.VBProject Set C = A.VBComponents.Item("My_Frmola").CodeModule On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For Each Rr In Sht.Range(Rng).SpecialCells(xlCellTypeFormulas) If Not IsEmpty(Rr) Then ReDim Preserve Ar_Ads(0 To F) ReDim Preserve Ar_Fm(0 To Lc) Ar_Ads(Lc) = "Sheets(""" & Rr.Worksheet.Name & """)" & "." & "Range(""" & Rr.Address(0, 0) & """)" '************************************************ ' إضافة شرط عند وجود علامة نصية يستبدلها بعلامتين نصيه Ar_Fm(F) = "=" & "Evaluate(""" & IIf(InStr(1, Rr.FormulaLocal, """", vbTextCompare) > 0, Replace(Rr.FormulaLocal, """", """"""), Rr.FormulaLocal) & """)" '************************************************ F = F + 1: Lc = Lc + 1 End If Next Next With C .AddFromString ("Sub Ali_Formola" & vbCrLf) For Prmit_A = LBound(Ar_Ads) To UBound(Ar_Ads) N = .CountOfLines .InsertLines N, Ar_Ads(Prmit_A) & Ar_Fm(Prmit_A) N = N + 1 Next .InsertLines N + 1, vbCrLf & "End Sub" End With Erase Ar_Ads: Erase Ar_Fm End Sub أرجو التجربه

السلام عليكم Public Sub Ali_SumPct() Dim A1, A2, A3 As Variant With Application .ScreenUpdating = False .EnableEvents = False With ورقة1 For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row A1 = Evaluate("=SUMPRODUCT((تاريخ>=$F$3)*(تاريخ<=$G$3)*(حالة=""صادر"")*(الاسم = " & .Cells(r, 1).Address(False, True) & ")*(عدد))") A2 = Evaluate("=SUMPRODUCT((تاريخ>=$F$3)*(تاريخ<=$G$3)*(حالة=""وارد"")*(الاسم = " & .Cells(r, 1).Address(False, True) & ")*(عدد))") A3 = Evaluate("= " & .Cells(r, 2) & "-" & .Cells(r, 3) & " ") .Cells(r, "B") = A1: .Cells(r, "C") = A2: .Cells(r, "D") = A3 Next End With .EnableEvents = True .ScreenUpdating = True End With End Sub

اخي اسلام الشيمي ملفك به معادلات كثيره جداً حوالي 11578 معادله عند تطبيق الكود عليه يظهر رسالة خطاء والرسالة تظهر لان الكود كبير جداً واعتقد تظهر عندي لإن الجهاز الذي اعمل عليه حاليا مواصفاته ضعيفه أرجو تجربة الكود في جهازك اذا كان جهاز حديث بعد تنفيذ الكود إضغط Alt + F8 وشغل الماكرو المسمى " Ali_Formola "

السلام عليكم إليك الشرح على الكود أرجو ان يفي بالغرض Private Sub CheckBox1_Click() Application.ScreenUpdating = False '********************************* ' الشرط التالي يعبر عن إذا الشيك بوكس عليه علامة صح إخي الصفوف 9 و 10 If CheckBox1.Value = True Then ' إخفاء الصفوف 9 و 10 Rows("9:10").EntireRow.Hidden = True '********************************* ' الشرط التالي يعبر عن إذا الشيك بوكس غير مفعل بعلامة صح إظهر الصفوف 9 و 10 ElseIf CheckBox1.Value = False Then ' إظهار الصفوف 9 و 10 Rows("9:10").EntireRow.Hidden = False ' نهاية الشرط End If Application.ScreenUpdating = True End Sub

السلام عليكم اخي إسلام الشيمي اخي الفاضل محمد ع تابع شرح المشاركة رقم 12 اذا كان الاوفيس الذي لديك 2007 اتبع الشرح التالي اذهب الى خيارات الإكسل ثم مركز التوثيق ثم إعدادات مركز التوثيق ثم إعدادت الماكرو ثم إعدادت وحدات الماكرو الخاصه بالمطورين وحفز على الثقه في الوصول إلى طراز كائن مشروع VBA اخي الحبيب المتألق رجب جاويش مرورك شرف لي اخي الكريم جزاك الله خير اخي الكريم حماده عمر الحمد لله انه عمل معك جزاك الله خير واعتقد يعمل مع كافة المعادلات ولاكن أرجو منك تجربته مع معادلات الصفيف إذا عمل أكيد بيعمل مع كل المعادلات اخي goodlife هل اتبعت الشرح الذي في المشاركة رقم 12 ارجو التجربه بعد تفعيل ثقة مشروع VBA

طيب اذهب الى قائمة أدوات ثم خيارات ثم امان ثم امان الماكرو ثم القائمة الجانبية ناشرون موثوقون ثم حفز الثقه بالوصول إلى مشروع Visual Basic

السلام عليكم غير موضح في الملف في ورقة إدخال اعمدة ساعات التدريب والتاريخ ؟ حاول تدخل بيانات وهميه وترفق الملف مره اخرى وإن شاء الله خير

السلام عليكم اخي حماده عمر جرب استبدل الكود المسمى Ad_Refe بالتالي نفس الكود عليه اضافه اعتقد تحل مشكلة رسالة الخطاء Private Sub Ad_Refe() On Error Resume Next With ThisWorkbook.VBProject.References .AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL" .AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB" .AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL" .AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3 .AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB" End With End Sub جرب وبلغنى بالنتائج تحويل المعادلات الى اكواد_A.rar

اخواني الاحبه هذا تعديل للكود بعد تجربته عند فتح اكثر من ملف واغلاق الملف الذي به الكود يفتح الملف مره اخرى وذلك بسبب التايمر في وضع التشغيل عموما هذا هو التعديل هذه الأكواد في حدث Thisworkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Ext End Sub Private Sub Workbook_Open() Call St_A End Sub وهذه الأكواد في مودويل Public Rm As Double Public Const C_Con = 3 Public Const Sc_W = "Ex" Public Sub St_A() On Error Resume Next Rm = Now + TimeSerial(0, 0, C_Con) Ali_C Rm, Sc_W, True End Sub Sub Ex() Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True St_A End Sub Public Sub Ext() Ali_C Rm, Sc_W, False End Sub Public Function Ali_C(St As Double, Sa As String, Bn As Boolean) On Error Resume Next With Application DoEvents .ScreenUpdating = False .EnableEvents = False .OnTime EarliestTime:=St, Procedure:=Sa, Schedule:=Bn .EnableEvents = True .ScreenUpdating = True End With End Function

السلام عليكم اخي goodlife هل عمل معك الكود ؟

غير الفونت مثلاً Courier New (العربية)

" Alt " + F8 وشغل الكود بيظهر في رسالة