أبو إسحاق

أشكر أخي أحمد على الرد لكن المستخدمين لا يتقيدون فايليت تلبية طلبي وإثراء الموضوع بالكود المطلوب إن أمكن ولكم جزيل الشكر

السلام عليكم لدي ملف وأرغب في أن ألزم المستخدم أن يستخدم رموز معينه للإدخال هذه الرموز موجودة في الشيت الأول وباقي الصفحات شيت2 وشيت3 للعمل حاليا أستخدم هذه المعادلة في المدى المطلوب وهي فعالة =IF(SUMPRODUCT(COUNTIF(Sheet1!B4:O24,E7))=1,1,0) المشكلة أحيانا بعض المستخدمين يقومون بالنسخ من أمكان مختلفه وتختفي خاصية التحقق أريد نفس الطريقة ولكن VBA مرفق ملف للعمل ولكم جزيل الشكر Book2.xlsm

مشكور أخوي علي: بعد الدمج الكود يعمل كانت هناك رسالة خطأ تظهر سببها مكان سطر فتح حماية الشيت غيرت مكانه لبداية الكود ، الآن 100% جزاك الله خير تحياتي لك

السلام عليكم طاب يومكم لدي كودان يعملان بشكل ممتاز إذا كان كل كود لوحده في الورقة ولكن عند وضع الإثنين في نفس الورقة أو دمجهم تأتي رسائل خطأ فأردت أن أدمج كودين بنفس الحدث Worksheet_Change في نفس الشيت الكود الأول يكتب تاريخ وقت التغيير في خلايا العمود w عندما يحدث هذا التغيير في الخلية المقابلة في العمود h Private Sub Worksheet_Change(ByVal Target As Range) Dim WorkRng As Range Dim Rng As Range Dim xOffsetColumn As Integer Set WorkRng = Intersect(Application.ActiveSheet.Range("h4:h1000"), Target) xOffsetColumn = 15 If Not WorkRng Is Nothing Then Application.EnableEvents = False For Each Rng In WorkRng If Not VBA.IsEmpty(Rng.Value) Then Rng.Offset(0, xOffsetColumn).Value = Now Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss" Else Rng.Offset(0, xOffsetColumn).ClearContents End If Next Application.EnableEvents = True End If End Sub الكود الثاني يعمل على فرز التاريخ تصاعدي على حسب التاريخ في خلايا العمود h Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Set Rng = Application.Intersect(Range("H3:H1000"), Range(Target.Address)) If Not Rng Is Nothing Then If Target.Column = 8 Then ActiveSheet.Unprotect officena Rng.Sort Key1:=Range("H4"), Order1:=xlAscending, _ Header:=xlGuess, OrderCustom:=1 End If ActiveSheet.Protect officena, AllowSorting:=True, AllowFiltering:=True End If End Sub ولكم جزيل الشكر my.xlsm

السلام عليكم لإنعدام خبرتي في الأكواد ... أطلب مساعدة في التعديل على هذا الكود معي الكود التالي: حيث هذا الكود يلغي قائمة صيّغ الحفظ المختلفه في نافذة "حفظ باسم" ويعطي خيارين "للحفظ بإسم" فقط هما xlsm و xls Excel Macro-Enabled Workbook (*.xlsm) Excel 97-2003 Workbook (*.xls) أنا أريد ألغي الخيارين أعلاه أيضا وأستبدالهم بالحفظ إلى PDF فقط لا غير هذا هو الكود Private Sub CustomSave(Optional SaveAs As Boolean) 'Declare the variables Dim ActiveSht As Object Dim FileFormat As Variant Dim FileName As String Dim FileFilter As String Dim FilterIndex As Integer Dim Msg As String Dim Ans As Integer Dim OrigSaved As Boolean Dim WorkbookSaved As Boolean 'Turn off screen updating Application.ScreenUpdating = False 'Turn off events so that the BeforeSave event doesn't occur Application.EnableEvents = False 'Assign the status of the workbook's Saved property to a variable OrigSaved = Me.Saved 'Assign the active sheet to an object variable Set ActiveSht = ActiveSheet 'Call the HideAllSheets routine Call HideAllSheets 'Save workbook or prompt for SaveAs filename If SaveAs Or Len(Me.Path) = 0 Then If Val(Application.Version) < 12 Then FileFilter = "Microsoft Office Excel Workbook (*.xls), *.xls" FilterIndex = 1 Else FileFilter = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, " & _ "Excel 97-2003 Workbook (*.xls), *.xls" If Right(Me.Name, 4) = ".xls" Then FilterIndex = 2 Else FilterIndex = 1 End If End If Do FileName = Application.GetSaveAsFilename( _ InitialFileName:=Me.Name, _ FileFilter:=FileFilter, _ FilterIndex:=FilterIndex, _ Title:="SaveAs") If FileName = "False" Then Exit Do If IsLegalFilename(FileName) = False Then Msg = "The file name is invalid. Try one of the " Msg = Msg & "following:" & vbCrLf & vbCrLf Msg = Msg & Chr(149) & " Make sure that the file name " Msg = Msg & "does not contain any" & vbCrLf Msg = Msg & " of the following characters: " Msg = Msg & "< > ? [ ] : | or *" & vbCrLf Msg = Msg & Chr(149) & " Make sure that the file/path " Msg = Msg & "name does not exceed" & vbCrLf Msg = Msg & " more than 218 characters." MsgBox Msg, vbExclamation, "Invalid File Name" Else If Val(Application.Version) < 12 Then FileFormat = -4143 Else If Right(FileName, 4) = ".xls" Then FileFormat = 56 Else FileFormat = 52 End If End If If Len(Dir(FileName)) = 0 Then Application.DisplayAlerts = False Me.SaveAs FileName, FileFormat Application.DisplayAlerts = True WorkbookSaved = True Else Ans = MsgBox("'" & FileName & "' already exists. " & _ "Do you want to replace it?", vbQuestion + vbYesNo, _ "Confirm Save As") If Ans = vbYes Then Application.DisplayAlerts = False Me.SaveAs FileName, FileFormat Application.DisplayAlerts = True WorkbookSaved = True End If End If End If Loop Until Me.Saved Else Application.DisplayAlerts = False Me.Save Application.DisplayAlerts = True WorkbookSaved = True End If 'Call the ShowAllSheets routine Call ShowAllSheets 'Activate the prior active sheet ActiveSht.Activate 'Set the workbook's Saved property If WorkbookSaved Then Me.Saved = True Else Me.Saved = OrigSaved End If 'Turn on screen updating Application.ScreenUpdating = True 'Turn on events Application.EnableEvents = True End Sub

أخي عملت ملف أكسل في أكسل 2016 وعملت له حماية للأوراق الحماية تعمل في أوفيس 2010 و 2013 و 2016 لكن في أوفيس 2007 بمجر الضغط على إلغاء الحماية تنلغي الحماية بدون ظهور نافذة الباسورد

السلام عليكم أخواني عندي مشكلة الباسورد المعموله في أكسل 2010 وما فوق تختفي في أكسل 2007 هل من حل حتى لو كان عن طريق كود

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

السلام عليكم إخواني أبحث عن كود يمنع المستخدم من القص ويسمح بالنسخ فقط ثم اللصق يكون لصق خاص للقيم ( يعني بدون تنسيق وغيره) شاكر لكم

لفائدة اكثر هل ممكن شرح الكود اذا حبيت أتوسع في الملف واضيف معادلات اخرى وماذا يعني كل سطر وما فائدة الأرقام 1+ و 4+ و1- و2- للصفوف والأعمدة وجازاك الله خيرا وزادك علما

مشكور أخي سليم الكود يعمل بإمتياز ربنا يحفظك وزادك الله من فضله

أشكرك أخي سليم على الرد الكود ممتاز هل يمكن أن يعمل الكود تلقائي بمجرد أدخال المعطيات لعملية الجمع لأن الكود الحالي لا يعمل تلقائي بإنتظارك أخي ولك الأجر

السلام عليكم تحية طيبة للجميع عندي معادلة صفيف في النطاق "H7:H26" تبدأ من الصف 7 إلى الصف 26 {=IF(OR(ISBLANK(C7:G7)),"",ROUND(SUM(C7,D7,E7,F7,G7),0))} المطلوب تحويها لكود vba حيث يتم تنفيذ كود المعادلة في النطاق "H7:H26" بدون إستخدام الأمر .FillDown تحويل خلايا النطاق إلى قيم .Value بدلا من معادلات يتم تحديث ناتج المعادلة تلقائي عند إدخال أو تغيير المعطيات ( بالضبط كما تعمل المعادلة بنفسها ) يا ريت الكود كاملا ولكم الشكر المثال مرفق Book100.zip

جميل جدا ولكن شي عجيب بصراحه لم أفهم كيف تعمل هذه التركبية ربنا يعطيك الصحة

أخوي سليم بارك الله فيك إنت أسئت فهم ما أريده أنا أنا لم أشتكي أن المعادله لا تعمل المعادله تعمل مع 100% ولا توجود بها أدنى مشكله عندما تكون كمعادلة في أكسل {=IF(OR(ISBLANK(C7:AF7));"";ROUND(SUM(BB7;BI7;BP7;BW7);0))} فقط أردت صياغة معادلة الصفيف هذه ككود فيجوال بيسك فأنا مبتدئ كما ذكرت وهذه محاولتي الأخيره عند وضعها ككود فيجوال بيسك Selection.FormulaArray = _ "=IF(OR(ISBLANK(C7:AF7)),"""",ROUND(SUM(BB7,BI7,BP7,BW7),0))" المعادله هذه تعمل ولكن المشكله تعمل في خليه واحده فقط وتعمل فقط عن إختيار الخليه بالفأره وهذا الذي لا أرغب به ---------------------------- كل ما أردته ذكرته في المشاركة رقم واحد 1 فا ريت المساعده منك ومن باقي الأخوان في صياغة كود كامل