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

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

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

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

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

أخي الكريم محمود أحبك الله الذي أحببتنا فيه بالنسبة لتغيير اسم الظهور للغة العربية ..راجع التوجيه العاشر في موضوع التوجيهات في الموضوعات المثبتة في المنتدى إليك الكود التالي يوضع في حدث ورقة العمل ..كليك يمين على اسم ورقة العمل المسماة "طلمبات المياة" ثم الأمر View Code ثم الصق الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 5 And Target.Row > 4 Then Application.ScreenUpdating = False Application.EnableEvents = False If Target.Value > Target.Offset(, -1) Or IsEmpty(Target.Offset(, -1)) Then MsgBox "الكمية المباعة أكبر من الكمية الموجودة أو لا يوجد كميات موجودة على الإطلاق", vbExclamation Target.ClearContents: Target.Activate Else Target.Offset(, -1).Value = Target.Offset(, -1).Value - Target.Value Target.ClearContents: Target.Offset(1).Activate End If Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub أرجو أن يكون المطلوب تقبل تحياتي Substract From Target Offset Cell Worksheet Change YasserKhalil.rar

بسم الله ما شاء الله عليك يا أخي الغالي حسام حطاب (متدورش ع النقطة ..أنا هجيبهالك) عمل رائع ومتقن وإبداعي بشكل منقطع النظير تقبل وافر تحياتي

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

أخي الكريم علاء عامر الحمد لله أن تم المطلوب على خير .. وجزيت خيراً بمثل ما دعوت تقبل تحياتي

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

أخي الفاضل حسام يرجى تغيير اسم الظهور للغة العربية إليك الكود التالي عله يفي بالغرض Sub TransferDataFromRowsToColumns() Dim I As Long, lRow As Long lRow = 9 Application.ScreenUpdating = False For I = 2 To Cells(4, Columns.Count).End(xlToLeft).Column Step 10 Cells(lRow, 1).Value = Cells(4, I + 2).Value Cells(lRow, 2).Resize(, 2).Value = Cells(4, I).Resize(, 2).Value Cells(lRow, 4).Value = Cells(4, I + 7).Value Cells(lRow, 5).Value = Cells(4, I + 6).Value Cells(lRow, 6).Resize(, 3).Value = Cells(4, I + 3).Resize(, 3).Value Cells(lRow, 9).Resize(, 2).Value = Cells(4, I + 8).Resize(, 2).Value lRow = lRow + 1 Next I Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي Transfer Data From One Row To Multiple Rows & Columns YasserKhalil.rar

المعادلة الموجودة في الملف المرفق تعتمد على ملف خارجي ..!! ولا تعتمد على المصنف نفسه ..في هذه الحالة يرجى إرفاق الملف الخارجي المرتبط به .. مع شرح ما المهمة التي تقوم بها المعادلة؟

أخي الكريم محمد إليك الكود التالي يوضع في حدث ورقة العمل كليك يمين على اسم الورقة المسماة CV .. ثم اختر الأمر View Code والصق الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("C4")) Is Nothing Then Call ChangePic End If End Sub وضع الكود التالي في موديول عادي Sub ChangePic() Dim pic As Picture, strPhotosFolder As String, strPhoto As String strPhotosFolder = ThisWorkbook.Path & "\Photos\" Application.ScreenUpdating = False With Sheets("CV") While .Pictures.Count .Pictures(1).Delete Wend strPhoto = strPhotosFolder & Trim(.Range("C4").Value) & ".*" strPhoto = Dir(strPhoto) If Len(strPhoto) Then strPhoto = strPhotosFolder & strPhoto .Pictures.Insert (strPhoto) Set pic = .Pictures(.Pictures.Count) With pic .ShapeRange.LockAspectRatio = msoFalse .Left = .Parent.Range("G2:G4").Left .Top = .Parent.Range("G2:G4").Top .Width = .Parent.Range("G2:G4").Width .Height = .Parent.Range("G2:G4").Height End With End If End With Application.ScreenUpdating = True End Sub تقبل تحياتي CV Employees Import Pictures Based On ID YasserKhalil.rar

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

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

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

جرب أن تستبدل السطر الذي به الخطأ بهذا السطر If IsEmpty(Cells(i, "A")) Then تقبل تحياتي

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

أخي الحبيب مختار جربت وضع الأرقام 1 و 2 و 3 و 4 في الأربعة صفوف .. ولم يحدث معي خطأ ارفق الملف مع التعديل الذي قمت به للإطلاع عليه ... ملحوظة : التسميات مستخدمة في الكود

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

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

أخي الحبيب حسام عيسى اللي مش حارمنا من حاجة أيداً إليك أخي الكريم خليلو (الرجاء تغيير اسم الظهور للغة العربية) إليك الملف المعدل Sudoku Games (Pass_123456).rar

أخي الغالي المتميز مختار بارك الله فيك وجزيت خيراً على هذا الإبداع أخي وحبيبي في الله بن عليه حاجي جزيت خير الجزاء على شرارة الإنطلاق الإبداعية إليكم إثراءً للموضوع الكود التالي Sub FindCombinations() Dim V(1 To 4) As Variant, W(1 To 4) As Variant, P As Variant Dim PCount&, I&, II&, III&, IIII& Dim Target As Single, Cell As Range ReDim P(1 To 4, 1 To 1) For I = 1 To 4 With Union([Ligne_1], [Ligne_2], [Ligne_3], [Ligne_4]).Areas(I) V(I) = .Value W(I) = .Value II = 0 For Each Cell In .Cells II = II + 1 W(I)(1, II) = Cell.Address Next Cell End With Next I Target = [Cellule1].Value For I = 1 To UBound(V(1), 2) For II = 1 To UBound(V(2), 2) For III = 1 To UBound(V(3), 2) For IIII = 1 To UBound(V(4), 2) If Target = V(1)(1, I) + V(2)(1, II) + V(3)(1, III) + V(4)(1, IIII) Then PCount = PCount + 1 ReDim Preserve P(1 To 4, 1 To PCount) P(1, PCount) = W(1)(1, I) P(2, PCount) = W(2)(1, II) P(3, PCount) = W(3)(1, III) P(4, PCount) = W(4)(1, IIII) End If Next IIII Next III Next II Next I Application.ScreenUpdating = False [B16:F65000].ClearContents [C16:F16].Resize(PCount).Value = Application.Transpose(P) [B16].Value = 1 [B16].Resize(PCount).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False Application.ScreenUpdating = True End Sub تقبلوا تحياتي Find Every Combination YasserKhalil.rar

أخي الكريم علام عامر أعتذر عن التأخر في الرد عليك ..ولكن ما نسيتك إليك الكود التالي يوضع في حدث ورقة العمل ..كليك يمين على اسم ورقة العمل المسماة "كشف تفريغ المدارس" ثم في النافذة لمحرر الأكواد ضع الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address(0, 0) <> "B2" Then Exit Sub Dim X, I&, J&, K& With Sheet1 X = .Range("A2:AD" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With ReDim Y(1 To UBound(X, 2) * 3, 1 To 3) For I = 2 To UBound(X) For J = 4 To UBound(X, 2) If X(I, J) = Target Then If Weekday(X(1, J), vbSunday) < 6 Then K = K + 1 Y(K, 1) = X(I, 2) Y(K, 2) = X(I, 3) Y(K, 3) = X(1, J) End If End If Next J Next I Range("A5").CurrentRegion.Offset(1).ClearContents If K > 0 Then Range("A6:C6").Resize(K).Value = Y End Sub تقبل تحياتي تفريغ الزائرين.rar

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

بارك الله فيك أخي الغالي مختار أخي الكريم أبو حماده جرب الكود بهذا الشكل Private Sub TextBox1_Change() If Me.TextBox1.Text = "سبحان الله" Then Command1.Enabled = True Else Command1.Enabled = False End If End Sub تقبل تحياتي