مختار حسين محمود

أخى أبو يحيى طالما التنسيق الشرطى ولا التعديل فى المعادلات مش عايزه ليس أمامك الا Numeric format الذى فى كود الأستاذ جعفر

نعم كل شىء فى الاكسل له حل فى ملفك تم اضافة معادلة للتسلسل اعتمادا على رقم صف الخلية وتم تعديل معادلة خلية الاجمالى بحيث تتغير لتحسب اجمالى الخلايا من E2 الى الخلية اللى فوقها مباشرةً جرب اضافة أى عدد من الصفوف وادخال بيانات فى المرفق Add Rows mokhtar .rar

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

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

بوركت أخى أبى الحسن والحسين

السلام عليكم ورحمة الله وبركاته بعد اذن الأستاذ أسامه وباقى الأساتذة الأخ KHMB هذا كود لتلوين مدى معين بعد تمام اكتمال بياناته اعتمادا على عدد الخلايا الفارغة فيه Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Integer, Rownum As Integer, CountBlank As String LR = Cells(Rows.Count, 1).End(xlUp).Row For Rownum = 2 To LR CountBlank = Application.WorksheetFunction.CountBlank(Range(Cells(Rownum, "A"), Cells(Rownum, "H"))) If CountBlank = 0 Then Range(Cells(Rownum, "A"), Cells(Rownum, "H")).Interior.ColorIndex = 38 Next Rownum End Sub الكود يوضع فى حدث الورقة التلوين يعمل من الصف الثانى على الأعمدة من A الى H جرب المرفق التالى Color a row after entering the required information .rar

إنّا للّه و إنّا إليه راجعون نسأل الله سبحانه وتعالى أن يغفر له ويثبته ويرزقه الجنة اللهم آمين

آخى زياد بارك الله فيك الحمد لله أننا وفقنا فى اجابة سؤالك

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

السلام عليكم تريد كود للتسطير الآلى جرب الكود ده ضعه فى حدث الورقة Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False If Not Intersect(Target, Range("A2:i100")) Is Nothing Then With Selection .BorderAround ColorIndex:=xlAutomatic, Weight:=xlMedium End With End If Application.ScreenUpdating = True End Sub يمكن زيادة نطاق التسطير بالتعديل فى الكود

أخى وأستاذى العزيز عمر الرخامة ما تجيب الجمال والبساطة دى

أشكرك أستاذى الفاضل اضافة : دالة لتحديد عدد أبعاد أى مصفوفة UDF Function ElementCount(B As Variant) As Long Dim V As Variant, Z As Long For Each V In B Z = Z + 1 Next V Do ElementCount = ElementCount + 1 Z = Z / (UBound(B, ElementCount) - LBound(B, ElementCount) + 1) Loop Until Z = 1 End Function Function fDummy(B As Variant) As Long fDummy = ElementCount(B) End Function Sub testArray() Dim Arr(1 To 5, 4 To 7, 10, 1 To 9) Dim B As Variant Dim ND As Long B = Arr ND = fDummy(B) MsgBox "the number of dimensions for The array " & ND End Sub تحياتى لكم

استفسار آخى وأستاذى ياسر : هل نقدر نقول على المصفوفة الثنائية إنها هى التى يكون عدد الأعمدة فيها 2 و نقول على المصفوفة المتعددة إنها هى التى يكون عدد الأعمدة فيها 3 أو أكثر بغض النظر عن عدد الصفوف

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

بعيدا عن Option Base 1 أو نزود واحد على الأعمدة UBound(Arr) + 1 ايه رأيكم فى اسلوب الحلقات Sub mokhtest() Dim Arr Arr = Array("A", "B", "C", "D") For i = LBound(Arr) To UBound(Arr) Cells(3, i + 1).Value = Arr(i) Next i End Sub

أخى ابراهيم التصريح Dim Arr تمام زى ما قال أخونا ياسر من النوع Variant الرقم 4 فى الكود الأول = UBound(Arr) + 1 كله مفهوم بالنسبة لى ويمكن أن يكون الكود بالشكل ده Sub Fillrangeusingarray() Dim Arr Arr = Array("A", "B", "C", "D") Range("A3").Resize(LBound(Arr) + 1, UBound(Arr) + 1) = Arr End Sub لكن حاسس إن فيه حاجة جديدة فى خزانة أبى البراء !!!

أستاذى الغالى أنا لا أدرى حلولا أخرى ولذلك أسألك جائز الخلط بين الحلين يعنى نصرح بـ Option Base 0 ونزود واحد على الأعمدة UBound(Arr) + 1

ببساطة طالما المصفوفة بدأت من الصفر يبقا في الحالة دي عشان نحدد عدد الأعمدة نزود واحد UBound(Arr) + 1 فيه طريقة تانية إننا نضع جملة Option Base 1 يتم وضعه خارج الكود في قسم الإعلانات العامة في الموديول وفي الحالة دي مفيش داعي نزود واحد في السطر يعني الكود هيكون بالشكل ده Option Explicit Option Base 1 أظن أن الحل ده أبسط من الأول . أخى ياسر يا أستاذ الصرح فين الحل اللى ما جاش فى الشرح ؟

الاجابة : ستجدونها فى الجزء الثانى من شرح الأستاذ ياسر أظن أنها واضحة اضافة : نسخ نطاق مستخدما أسلوب المصفوفات لنفرض أنه عندى مجموعة قيم فى النطاق ("A1:A10") كيف يمكن نسخ هذا النطاق بطريقة المصفوفات ؟ الاجابة بكل بساطة : نخزن قيم النطاق فى مصفوفة ثم نحدد مكان التعبئة أو النسخ بس خلاص الكود المستخدم فى النسخ : اختر واحدا من الكودين التاليين : Sub copyrangeusingarray() Dim Arr Arr = Range("A1:A10") Range("D1").Resize(UBound(Arr), 1) = Arr 'نسخ عمودى End Sub Sub copyrangeusingarray2() Dim Arr Arr = Range("A1:A10") Range("G5").Resize(1, UBound(Arr)) = Application.Transpose(Arr) ' نسخ أفقى للبيانات End Sub بمقارنة الكودين نلاحظ اختلافا بعد كلمة Resize هذا الاختلاف ينجم عنه شكل النسخ أفقيا أو رأسيا وأستاذنا ياسر شرح لنا Application.Transpose يلا جرب الكودين مع وضع مجموعة قيم فى النطاق ("A1:A10") تحياتى لكم

أخى وأستاذى ياسر أشكرك على هذه الثقة ولكن أنا لا أفهم جيدا كل النقاط التى ذكرتها فى مشاركتى السابقة فأنا اقترحتها لتشرحها وتشرحها بأسلوبك كما أننى أضم صوتى لصوت أخى ابراهيم ابو ليله بأن أسلوبك مألوف لدى السواد الأعظم من الأعضاء . وأنا سوف أقدم ما يمكننى تقديمه واليك ولكل الأخوة : أكواد تعبئة نطاق أو أكثر بالبيانات مستخدما أسلوب المصفوفات ملحوظة : الأكواد مجمعة من مشاركات الأعضاء مع بعض التعديلات البسيطة Sub Fillrangeusingarray() Dim Arr Arr = Array("A", "B", "C", "D") Range("A3").Resize(1, UBound(Arr) + 1) = Arr End Sub Sub Fillrangeusingarray2() Dim Arr(1 To 7) As String Arr(1) = "sat" Arr(2) = "sun" Arr(3) = "mon" Arr(4) = "tue" Arr(5) = "wed" Arr(6) = "thu" Arr(7) = "fri" Range("A8").Resize(1, UBound(Arr)) = Arr ' تعبئة أفقية End Sub Sub Fillrangeusingarray3() ' الكود رقم 2 بشكل آخر مخنصر Dim Arr Arr = Array("sat", "sun", "mon", "tue", "wed", "thu", "fri") Range("A13").Resize(1, UBound(Arr) + 1) = Arr ' تعبئة أفقية End Sub Sub Fillrangeusingarray4() Dim Arr Arr = Array("sat", "sun", "mon", "tue", "wed", "thu", "fri") Range("A18").Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr) ' تعبئة رأسية End Sub Sub FillrangeSusingarray5() Dim i As Integer Dim Arr1 As Variant Dim Arr2(1 To 5) As String Arr2(1) = "ساعة الحضور" Arr2(2) = "ساعة الانصراف" Arr2(3) = "ساعات العمل" Arr2(4) = "ثمن الساعة" Arr2(5) = "جملة التكاليف" Arr1 = Array("السبت", "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة") Range("C3").Resize(1, UBound(Arr1) + 1) = Arr1 For i = LBound(Arr2) To UBound(Arr2) Cells(i + 3, "B") = Arr2(i) Next i End Sub تحياتى Fill range using array .rar

آخى وأستاذى العزيز أقترح مناقشة النقاط التالية : نسخ و حذف نطاق مستخدما المصفوفات : فى شيت - بين شيتين - بين ملفين المصفوفات الآحادية والثنائية والمتعددة . كيفية حذف عنصر أو مجموعة عناصر من مصفوفة المصفوفة الثابتة و المتحركة ( الديناميكية ) تفريغ مصفوفة من مجموعة القيم اللى أخدتها واعطائها قيما جديدة . وهل يمكن العودة للقيم القديمة بعد التفريع اللعب مع مصفوفتين نلون العناصر المتشابه بلون والمختلفة بلون وهكذا أعتقد أن ده هيفتح معانا موضوعات وأسئلة لن تنتهى تحياتى .

أستاذنا ياسر بارك الله فيك وجازاكم خيرا أخى زيزو البسكرى الكود فى ملفك فكرته جميله بجد الله ينور أخى حسام ده تعديل لكود أستاذنا ياسر الحذف يكون بدون علم المستخدم كما فى مرفق أخونا عبدالعزيز الكود فيه تاريخ بامكانك تعديله اذا كان تاريخ اليوم أكبر أو يساوى التاريخ اللى فى الكود مش هتلاقى الشيتات ما عدا واحد فقط اللى اسمه فى الكود "متوسط اوزان الشهر " الكود يوضع فى حدث المصنف Option Explicit Private Sub Workbook_Open() 'يقوم الكود بحذف جميع أوراق العمل بعد تاريخ محدد '----------------------------------------------- Dim exDate As Date, SH As Worksheet exDate = "10/08/2015" Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlManual If Date >= exDate Then For Each SH In ThisWorkbook.Sheets If SH.Name <> "متوسط اوزان الشهر " Then SH.Delete Next SH End If Application.Calculation = xlAutomatic Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub تحياتى

أخى حسام أولا لو كنت جربت وضع كود فى ملفك المرفق مش هينفع لان امتداده xlsx لو وضعت فيه كود مش هتلاقيه دى حاجة يجب أن تعرفها أولا سيبك من ده وسيبك من الكود يتحط فين وجاوبنى الأول : أنت ملفك المرفق فيه 31 شيت + شيت باسم : متوسط اوزان الشهر هل تريد مسح البيانات من كل الملف ولا من شيتات بعينها وذلك بعد مدة محددة أم تريد حذف شيتات معينة بعد مدة محددة يعنى ما تلاقيش الشيت نهائيا ؟ جاوب وان شاء الله تتحل .

بارك الله فيك يا زيزو يا بسكرى أخبارك وأخبار الحر فى بسكرة تحياتى ليك ولكل أهل الجزائر

السلام عليكم أخى وأستاذى العزيز ياسر لا تتخيل الحر فى اسيوط شديد جدا و مش مخلينى قادر أقعد شوية على الكمبيوتر على العموم ربنا يلطف بالنسبة لاجابة السؤال : Sub OneDimensionalArray5() Dim Arr Arr = Range("A1:A15") Range("k5").Resize(UBound(Arr), 1) = Arr End Sub اضافة متقدمة شوية لكن لم أجد أبسط منها للمشاركة ولكن هتفيدنا قدام شوية عند الحديث عن الثنائية وهى عن حجم المصفوفة : لو عندى مصفوفة أحادية وعايز أعرف حجمها أو ببساطة تتكون من كام عنصر Sub sizeofarray() Dim Arr(1 To 5) As String, x As Integer x = UBound(Arr, 1) - LBound(Arr, 1) + 1 MsgBox " هذه المصفوفة تتكون من " & x & " عنصر " End Sub لو عندى مصفوفة ثنائية وعايز أعرف حجمها الحجم = حاصل ضرب الطرفين Sub sizeofarray2() Dim Arr(1 To 5, 1 To 10) As String, x As Integer, y As Integer x = UBound(Arr, 1) - LBound(Arr, 1) + 1 y = UBound(Arr, 2) - LBound(Arr, 2) + 1 MsgBox " هذه المصفوفة تتكون من " & x * y & " عنصر " End Sub تحياتى لكم