ياسر خليل أبو البراء

السلام عليكم أخي الكريم حسن اعذرني لقلة وقتي لن أستطيع متابعة موضوعك .. ولكن اقتراح بسيط قد يروق لك لما لا تحدد الأعمدة المراد تحويل المعادلات منها إلى قيم ثم تقوم بنسخ الأعمدة ثم لصق خاص ولصق القيم فقط .. وبذلك تتخلص من الصيغ والمعادلات الموجودة وتحصل على القيم فقط ..

أخي الغالي أبو بهاء المصري جزيت خيراً على كلماتك الرقيقة أقصد بالتحديث هو استخدام أوفيس 2007 فما فوق ... حيث أن أوفيس 2003 إمكانياته محدودة للغاية ، فما قدمه لك الأخ الحبيب مختار كان ليكفي لو أنك تستخدم إصدار أحدث عموماً بالنسبة لطلبك الثاني لدي حل جزئي له ربما يروق لك .. فقط اطرحه في موضوع جديد حتى يساهم كل الأعضاء فيه إن شاء الله وكل عام وأنت بخير

أخي الكريم أهلا ومرحباً بك في المنتدى يرجى إرفاق ملف بعد ضغطه لتتمكن من رفعه كما يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لمعرفة كيفية التعامل مع المنتدى

جرب هذا التعديل Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 3 And Target.Column = 6 Then Dim Cell As Range Application.ScreenUpdating = False Rows("4:28").EntireRow.Hidden = False For Each Cell In Range("A4:A28") If IsEmpty(Cell) Then Cell.EntireRow.Hidden = True Next Cell Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Hidden = False Range("F" & Cells(Rows.Count, 1).End(xlUp).Row).Select Application.ScreenUpdating = True End If End Sub تقبل تحياتي

بسم الله ما شاء الله أخي الحبيب الغالي المتمكن مختار ايه الجمال ده ... صراحة في منتهى الروعة والابداع والاختصار أنا صراحة اشتغلت على الكود الموجود وعدلت طبقاً لما طلبه الاخوة من مسار الحفظ وفتح الملف بعد التحويل .. بس كودك هو الأفضل والأيسر بلاشك

أخي الكريم أحمد أبو زيزو أفضل إرفاق ملف للإطلاع عليه والعمل عليه إن أمكنني ذلك إن شاء الله

جرب الملف تكرار تلقائي.rar

أخي الكريم راجع التوجيهات في الموضوعات المثبتة في المنتدى

الأخ الحبيب مختار أستاذ ورئيس قسم جزاك الله خير الجزاء في الدنيا والآخرة الدالة من الدوال المفيدة جداً والمحببة لدي شخصياً .. مساهمةً مني إليك ملف لتطبيق الفكرة عليه بأسلوب أسهل ألا وهو كتابة اسم الصور في عمود والإشارة إلى الخلية في المعادلة التي سيتم كتباتها كما هو موضح بالمرفق .. Insert Picture UDF Function.rar

الأخ العزيز عزيز .. كل عام وأنت بخير جرب الكود التالي عله يفي بالغرض Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 3 And Target.Column = 1 Then Dim Cell As Range Application.ScreenUpdating = False Rows("4:28").EntireRow.Hidden = False For Each Cell In Range("A4:A28") If IsEmpty(Cell) Then Cell.EntireRow.Hidden = True Next Cell Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Hidden = False Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Select Application.ScreenUpdating = True End If End Sub تقبل تحياتي Hide All Blank Rows Except One.rar

أخي الحبيب سليم بارك الله فيك على الموضوع المتميز والرائع .. فكرتنا بأيام زماااان أخي الغالي أبو يوسف كود في منتهى الروعة وحل بارع .. تسلم الأيادي

أخي الحبيب الغالي المتميز أسامة البراوي يبدو أننا فزنا بشخص متميز جداً .. بارك الله فيك وجزاك الله خير الجزاء .. عمل في منتهى الاتقان والروعة والتميز والجمال و و و و لن تصف الكلمات مدى روعة العمل مهما بلغت قوة وبلاغة وفصاحة الكلمات جعله الله في ميزان حسناتك يوم القيامة لقد أحييت في الأمل من جديد

أخي الحبيب الغالي السباق بالخير مختار بارك الله فيك وجزيت خير الجزاء أخي الكريم أبو بهاء المصري .. لي عتاب بسيط .. يرجى ألا تكثر الطلبات في موضوع واحد .. ماذا يضرك إذا جعلت كل طلب في موضوع منفصل كي يجد الباحث فيما بعد بغيته إذا أراد البحث إليك الملف التالي عله يفي بالغرض (وإن كنت من أنصار التحديث والتجديد ومواكبة العصر) Sub GenerateRandom() Range("A10:A210").Formula = "=RandomNumbers(1,12)" End Sub Sub ClearRange() Range("A10:A210").ClearContents End Sub Public Function RandomNumbers(Lowest As Long, Highest As Long, Optional Decimals As Integer) Application.Volatile If IsMissing(Decimals) Or Decimals = 0 Then Randomize RandomNumbers = Int((Highest + 1 - Lowest) * Rnd + Lowest) Else Randomize RandomNumbers = Round((Highest - Lowest) * Rnd + Lowest, Decimals) End If End Function يمكنك توليد أرقام بها كسور وليست أرقام صحيحة فقط من خلال التعديل في المعادلة =RandomNumbers(1,12,1) كل عام وأنتم بخير Random Numbers YasserKhalil.rar

الأخ الكريم Creation يرجى تغيير اسم الظهور للغة العربية الأخ الحبيب مختار بارك الله فيك وجزاك الله خير الجزاء الأخ الكريم الميساني .. إليك الكود بعد التعديل .. يمكنك من خلال الكود تعديل المسار واسم المللف كما يمكنك فتح الملف بعد التحويل من خلال آخر سطر تمت إضافة تعليقات على الأسطر التي يمكنك من خلالها التعديل Sub Convert_PDF() 'في مسار محدد من خلال الكود ثم فتح الملف [PDF] يقوم الكود بتحويل نطاق محدد إلى ملف '-------------------------------------------------------------------------------- On Error Resume Next Dim FileName As String, MyFileName As String, MS As String Dim Rng As Range If ActiveWindow.SelectedSheets.Count > 1 Then MsgBox "There is more then one sheet selected," & vbNewLine & "ungroup the sheets and try the macro again." Else On Error Resume Next '[PDF] تعيين النطاق المطلوب تحويله إلى Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) If Not Rng Is Nothing Then Debug.Print Rng.Address(External:=True) Rng.Select 'يمكن تغيير مسار الحفظ واسم الملف من خلال هذا السطر MyFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & ActiveSheet.[A1].Value FileName = Create_PDF(Selection, MyFileName, True, True) If FileName <> MyFileName Then MS = MsgBox("تم التحويل والحفظ بنجاح", vbInformation, "منظومة الصرافة") Else MS = MsgBox("قمت بإلغاء المهمة لذلك لم يتم التحويل", vbCritical, "منظومة الصرافة") End If End If End If 'بعد التحويل [PDF]سطر لفتح ملف الـ ActiveWorkbook.FollowHyperlink MyFileName & ".PDF" End Sub Function Create_PDF(Myvar As Object, FixedFilePathName As String, OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String Dim FileFormatstr As String Dim Fname As Variant If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _ & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then If FixedFilePathName = "" Then FileFormatstr = "PDF Files (*.jpeg), *.jpeg" Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _ Title:="Create PDF") If Fname = False Then Exit Function Else Fname = FixedFilePathName End If If OverwriteIfFileExist = False Then If Dir(Fname) <> "" Then Exit Function End If On Error Resume Next Myvar.ExportAsFixedFormat _ Type:=xlTypePDF, _ FileName:=Fname, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False On Error GoTo 0 If Dir(Fname) <> "" Then Create_PDF = Fname End If End Function كل عام وأنتم بخير

جرب الملف التالي ..قل الاهتزاز قليلاً تكرار تلقائي.rar

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

أخي قم بإدراج الكود الي يعمل معك .. وكيف عمل الكود وفي نفس الوقت لم تحل المشكلة بعد !!!

الأخ الحبيب الغالي علاء رسلان اعذرني لقلة وقتي سأرشدك إلى ما يمكنك من خلاله الإطلاع أكثر على الدالة .. افتح ملف إكسيل واضغط F1 من لوحة المفاتيح واكتب في خانة البحث كلمة Subtotal لمعرفة المزيد حول استخدام الدالة .. تقبل الله منا ومنكم

الأخ الكريم زوهير كلما زادت المشقة زاد الأجر بإذن الله أعانكم الله وتقبل منا ومنكم بالنسبة لطلبك غاية في اليسر والسهولة .. وهو قبل الكود أن تقوم بحماية الورقة بكلمة سر ولكن قبل ذلك تحدد خلايا الإدخال وكليك يمين ومن آخر تبويب Protection شيل علامة الصح من جانب الخيار Locked ومن جانب الخيار Hidden ؛ عشان تستثني الخلايا دي من الحماية .. وبعدين فعل الحماية بأي كلمة سر مثلاً في الملف المرفق كلمة السر 1 (الله واحد لا شريك له) .. وقبل الكود تضع سطر لفك الحماية بكلمة السر المحددة كما بهذا الشكل ActiveSheet.Unprotect 1 وبعد تنفيذ الكود تعود الحماية بسطر آخر ActiveSheet.Protect 1 جرب الملف المرفق وإن شاء الله يكون المطلوب تقبل تحياتي Sum Values Between Two Dates.rar

أخي الحبيب أبو يوسف إليك الكود التالي عله يفي بالغرض ضع الكود في موديول جديد Sub TellMe() Dim CalState CalState = Application.Calculation If CalState = -4135 Then MsgBox "Calculation Is Manual" End Sub ثم ضع الأكواد التالية في حدث المصنف Private Sub Workbook_BeforeClose(Cancel As Boolean) TellMe End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) TellMe End Sub Private Sub Workbook_Open() TellMe End Sub سيتم التذكير عند فتح المصنف وعند حفظ المصنف وعند إغلاق المصنف أرجو أن يكون هذا هو المطلوب Warn Me.rar

جرب هذا التعديل Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 3 Or Target.Column = 5 Then Application.ScreenUpdating = False Application.EnableEvents = False Unique End If Sheets("الخارج").Select Application.EnableEvents = True Application.ScreenUpdating = True End Sub

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

أخي الترتيب في التسلسل في الملف المرفق من قبلك صحيح بالنسبة لي قم بالدخول على التبويب Formulas ثم Calcualtion Options واختر Automatic ستجد الترتيب في التسلسل صحيح إن شاء الله

أخي الحبيب ياسر فتحي كل عام وأنت بخير إليك الكود التالي لعله يفي بالغرض (طبعاً الكود مش كودي عشان متقولش اشرحه ) Sub SUMIFSVBA() Dim Rng As Range, arrNet, arrName, arrGroup, arrOutput, Coll As New Collection Dim I As Long, J As Long, E As Long, P As Long, str1 As String With Sheets("Sales Report") arrNet = Intersect(.Columns("F"), .UsedRange).Value arrName = Intersect(.Columns("L"), .UsedRange).Value arrGroup = Intersect(.Columns("C"), .UsedRange).Value End With With Sheets("Achievement") Set Rng = .Range("A4:EH50") arrOutput = Rng.Formula End With For I = 2 To UBound(arrNet, 1) str1 = arrName(I, 1) & Chr(2) & arrGroup(I, 1) On Error Resume Next Coll.Add Key:=str1, Item:=Coll.Count + 1 E = Err.Number On Error GoTo 0 P = Coll(str1) If E = 0 Then arrNet(P, 1) = Val(arrNet(I, 1)) Else arrNet(P, 1) = arrNet(P, 1) + Val(arrNet(I, 1)) End If Next I For I = 1 To UBound(arrOutput, 1) If IsNumeric(arrOutput(I, 1)) Then For J = 5 To 137 Step 3 On Error Resume Next P = Coll(arrOutput(I, 2) & Chr(2) & arrOutput(1, J - 1)) E = Err.Number On Error GoTo 0 If E = 0 Then arrOutput(I, J) = arrNet(P, 1) Else arrOutput(I, J) = 0 End If Next J End If Next I Rng.Formula = arrOutput End Sub Sub ClearConstants() Dim Rng As Range, Arr, I As Long, J As Long With Sheets("Achievement") Set Rng = .Range("A4:EH50") Arr = Rng.Formula End With For I = 1 To UBound(Arr, 1) If IsNumeric(Arr(I, 1)) Then For J = 5 To 137 Step 3 Arr(I, J) = "" Next J End If Next I Rng.Formula = Arr End Sub إن شاء الله يفي بالغرض

أخي الحبيب خالد الرشيدي إبداع بلا حدود .. بارك الله فيك وجزيت خيراً على الشرح الوافي والرائع والمتميز