ناصر سعيد

'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 15/2/2017 Sub استدعاء_كنترول_جميع() Dim arr As Variant Dim temp As Variant Dim cr As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long Dim ws As Worksheet Dim sh As Worksheet Set ws = Sheets("رصد الترم الثانى") Set sh = Sheets("كنترول شيت") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("A12:DW1000").ClearContents ' اسم ورقة المصدر lr = ws.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = ws.Range("A7:GG" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 111, 111, 111, 131, 132, 133, 134, 135, 136, 125, 126, 127, 111, 111, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 101, 102) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' If arr(i, 101) Like "ناجح" Then If arr(i, 101) Like "*" & "نا*" & "*" _ Or arr(i, 101) Like "*" & "له* دور*" & "*" Then temp(j, 1) = j For c = LBound(cr) To UBound(cr) temp(j, c + 2) = arr(i, cr(c)) Next c j = j + 1 End If Next i ' اسم شيت الهدف With sh .Range("A11").Resize(j - 1, UBound(temp, 1)).Value = temp 'سطر لمسح التسطير .Range("A11:DW" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("A11:DW" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Weight = xlMedium End With End Sub بالرغم من ان سطر المسح في الكود محدد الا انه يمسح الصفحه كيف يمكن ان يكون محدد مدى المسح ؟ جزاكم الله خيرا

وصلت الفكره .. تمام التمام ربنا يجزيك كل خير ويبارك فيك استاذ خالد الرشيدي كيف ؟

اولا ... جزاك الله خيرا استاذ خالد الرشيدي وبعد : الجزء الاول من الاجابه الخاص بالرقم 7 لازاحه الصفوف قف على الخليه B5 وفك الدمج ستجدها تحولت الى B10 ومع اننا وضعنا الرقم 7 ستاتي النتائج سليمه ... كيف ؟ مش المطلوب ازاحه واحده من 10 الى 11 ... ؟ ==== ثانيا الجزئيه الخاصه بالنسخ عدد الصفوف التي يتم نسخها مطاط يعني يتغير في اغلب الاوقات ولذلك بنأتي بمعادله في الخليه O1 لتاتي بالعدد .... هل يمكن ان يتم النسخ على المدى الموجود فعليا ام ان فكرتي جانبها الصواب

Range("A11:DW11").AutoFill Destination:=Range("A11:DW" & Range("O1").Value + 10), Type:=xlFillDefault هذا السطر يعتمد في النسخ على الخليه O1 .. هل يمكن ان نجعل النسخ لايعتمد على هذه الخليه ويعتمد على فكره اخرى .. كرما منكم

ان اراد الله وجلست مع الكمبيوتر وسمح وقتك ... ارجو التعليق على الملحوظه خاصتي ولك الشكر والتقدير

الاستاذ المحترم خالد الرشيدي اضافه الرقم 7 كما تفضلت سليمه ولكن ليه اخترت عمود ال C ثانيا عمود ال C فيه خلايا مدمجه ... فكيت الدمج فاصبحت C10 وشغلت الكود سليمه بالرغم من وجود نفس الرقم 7 ... سامحني مش فاهمها جزاك الله خيرا

جزاك الله كل خير وبارك فيك استاذ خالد الرشيدي هل الرقم 2 ده يعبر عن رقم صف بدايه صفحه المصدر (رصد الترم الثانى ) ؟

بسم الله الرحمن الرحيم كل عام وانتم بخير هذا كود عند الضغط على زر استدعاءات لاتاتي البيانات من اول صف البيانات المصدر .. اين التعديل من فضلكم كود استدعاء.rar

جزاك الله كل خير وبارك فيك استاذ خالد الرشيدي ساعمل بالحل الاول مبدئيا الى ان ياتي الله بحل برمجي

ماهو التغيير اللازم في الكود لكي اجعل عمود ال P وعمود Q الملونين باللون الاصفر ليس بهم بيانات مستجلبه جزاكم الله خيرا استدعااء.rar

استاذ زيزو يحفظك الخالق ويرعاك

المحترم زيزو العجوز جزاك الله كل خير وبعد هل يمكن اضافه تسطير الخلايا لشيتات الناجحين والراسبين اوتوماتيك ؟

'=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 15/2/2017 Sub استدعاء() Dim arr As Variant Dim temp As Variant Dim cr As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long Dim ws As Worksheet Dim sh As Worksheet Set ws = Sheets("Sheet1") Set sh = Sheets("Sheet2") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B7:AJ10000").ClearContents ' اسم ورقة المصدر lr = ws.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = ws.Range("A7:EF" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به ورقم عمود المعيار If arr(i, 135) Like "*" & "نا*" & "*" Then temp(j, 1) = j For c = LBound(cr) To UBound(cr) temp(j, c + 2) = arr(i, cr(c)) Next c j = j + 1 End If Next i ' اسم شيت الهدف With sh .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير .Range("B7:AJ" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1 End With End Sub هذا الكود خاص باستدعاء اعمده معينه بناء على شرط ... ( النجاح ) استدعاء بشرط1.rar

تمام التمام ... ربنا يحفظك ويصونك يارب يا استاذ ياسر 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 15/2/2017 Sub استدعاء() Dim arr As Variant Dim temp As Variant Dim cr As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long Dim ws As Worksheet Dim sh As Worksheet Set ws = Sheets("Sheet1") Set sh = Sheets("Sheet2") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B7:AJ10000").ClearContents ' اسم ورقة المصدر lr = ws.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = ws.Range("A7:EF" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به ورقم عمود المعيار If arr(i, 135) Like "*" & "نا*" & "*" Then temp(j, 1) = j For c = LBound(cr) To UBound(cr) temp(j, c + 2) = arr(i, cr(c)) Next c j = j + 1 End If Next i ' اسم شيت الهدف With sh .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير .Range("B7:AJ" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1 End With End Sub هذا ملف الكود وبه اسم شيت المصدر واسم شيت الهدف من ضمن المتغيرات في اول الكود استدعاء بشرط.rar

ربنا يبارك فيك استاذ ياسر .. عمل ولا اروع '=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 15/2/2017 Sub استدعاء() Dim arr As Variant Dim temp As Variant Dim cr As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long 'متغير اسم شيت الهدف والمدى المطلوب مسحه Sheets("Sheet2").Range("B7:AJ10000").ClearContents 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A7:EF" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به ورقم عمود المعيار If arr(i, 135) Like "*" & "نا*" & "*" Then temp(j, 1) = j For c = LBound(cr) To UBound(cr) temp(j, c + 2) = arr(i, cr(c)) Next c j = j + 1 End If Next i 'متغير اسم شيت الهدف With Sheets("Sheet2") .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير .Range("B7:AJ" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1 End With End Sub ======================== هذا الكود خاص باستدعاء اعمده معينه بناء على شرط ( النجاح ) استدعاء بشرط.rar

شكرا لك اخي الكريم ولكن تعطي هذه الرساله

للرفع رفع الله مقداركم

كود لوضع دوائر حسب معطيات الغياب واقل من درجه معينه في اعمده معينه... يحفظك ربنا ويرعاك الاستاذ زيزو العجوز الكود التالى لمسح الدوائر و استخدم زر " Button" بدلا من استخدام الشكل التلقائى Sub Circles() 'هذا الكود للمحترم النابغه زيزو العجوز 'الهدف من الكود هو وضع دوائر على درجات في اعمده معينه 'تم هذا الكود في 19/5/2017 'استدعاء كود المسح اولا Call DeletingShp 'متغيرات Dim ws As Worksheet Dim Arr() As Variant Dim LR As Long, R As Long, i As Long Dim Cel As Range 'اسم صفحه العمل Set ws = Sheets("شيت") ' هذا شرط الا يعمل الكود قبل الصف 14 If LR < 14 Then LR = 14 'متغير لعد الصفوف LR = ws.Range("C" & Rows.Count).End(xlUp).Row 'ارقام الاعمده المطلوب وضع دوائر فيها Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37) 'بدايه الصفوف For R = 14 To LR ' عرض المصفوفة الخاصة بالاعمدة For i = LBound(Arr) To UBound(Arr) ' نطاق تطبيق الامر وهو الخاص برسم الدوائر For Each Cel In ws.Cells(R, Arr(i)) ' الشرط الذى على اساسه سوف يتم رسم الدوائر If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then ' مواصفات الشكل وهو هنا عبارة عن دائرة وما بين الاقواس هو ابعاد الدائرة حتى لا تصبح اكبر من حجم الخلية Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height) ' مواصفات الدائرة من حيث درجة اللون وحجم الخط و الشفافية xx.Fill.Visible = msoFalse xx.Line.ForeColor.SchemeColor = 10 xx.Line.Weight = 1.2 End If Next Next Next End Sub ' الكود الثانى Sub DeletingShp() '' المتغيرات Dim shp As Shape, x As Long ' هذا النطاق يسمح بمسح كل الاشكال فى ورقة العمل سواء دائرة او غيرها For Each shp In ActiveSheet.Shapes ' امر المسح If shp.Type = 1 Then shp.Delete: x = x + 1 Next shp ' رسالة بعدد الدوائر التى تم مسحها 'MsgBox "تم حذف " & x & " دائرة بنجاح", vbMsgBoxRight, "الحمدلله" End Sub ============= كود الدوائر وكود مسحها.

الكود اخذ حقه ... يحفظك ربنا ويرعاك الاستاذ زيزو العجوز استخدم الكود التالى لمسح الدوائر و استخدم زر " Button" بدلا من استخدام الشكل التلقائى Sub Circles() 'هذا الكود للمحترم النابغه زيزو العجوز 'الهدف من الكود هو وضع دوائر على درجات في اعمده معينه 'تم هذا الكود في 19/5/2017 'استدعاء كود المسح اولا Call DeletingShp 'متغيرات Dim ws As Worksheet Dim Arr() As Variant Dim LR As Long, R As Long, i As Long Dim Cel As Range 'اسم صفحه العمل Set ws = Sheets("شيت") ' هذا شرط الا يعمل الكود قبل الصف 14 If LR < 14 Then LR = 14 'متغير لعد الصفوف LR = ws.Range("C" & Rows.Count).End(xlUp).Row 'ارقام الاعمده المطلوب وضع دوائر فيها Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37) 'بدايه الصفوف For R = 14 To LR ' عرض المصفوفة الخاصة بالاعمدة For i = LBound(Arr) To UBound(Arr) ' نطاق تطبيق الامر وهو الخاص برسم الدوائر For Each Cel In ws.Cells(R, Arr(i)) ' الشرط الذى على اساسه سوف يتم رسم الدوائر If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then ' مواصفات الشكل وهو هنا عبارة عن دائرة وما بين الاقواس هو ابعاد الدائرة حتى لا تصبح اكبر من حجم الخلية Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height) ' مواصفات الدائرة من حيث درجة اللون وحجم الخط و الشفافية xx.Fill.Visible = msoFalse xx.Line.ForeColor.SchemeColor = 10 xx.Line.Weight = 1.2 End If Next Next Next End Sub ' الكود الثانى Sub DeletingShp() '' المتغيرات Dim shp As Shape, x As Long ' هذا النطاق يسمح بمسح كل الاشكال فى ورقة العمل سواء دائرة او غيرها For Each shp In ActiveSheet.Shapes ' امر المسح If shp.Type = 1 Then shp.Delete: x = x + 1 Next shp ' رسالة بعدد الدوائر التى تم مسحها 'MsgBox "تم حذف " & x & " دائرة بنجاح", vbMsgBoxRight, "الحمدلله" End Sub ============== كود الدوائر وكود مسحها.rar

اكمل جميلك واشرح الاسطر الباقيه يحفظك الله ويرعاك استاذ زيزو Sub Circles() 'هذا الكود للمحترم النابغه زؤزو العجوز 'الهدف من الكود هو وضع دوائر على درجات في اعمده معينه 'تم هذا الكود في 19/5/2017 'استدعاء كود المسح اولا Call DeletingShp 'متغيرات Dim ws As Worksheet Dim Arr() As Variant Dim LR As Long, R As Long, i As Long Dim Cel As Range 'اسم صفحه العمل Set ws = Sheets("شيت") If LR < 14 Then LR = 14 'متغير لعد الصفوف LR = ws.Range("C" & Rows.Count).End(xlUp).Row 'ارقام الاعمده المطلوب وضع دوائر فيها Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37) 'بدايه الصفوف For R = 14 To LR For i = LBound(Arr) To UBound(Arr) For Each Cel In ws.Cells(R, Arr(i)) If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height) xx.Fill.Visible = msoFalse xx.Line.ForeColor.SchemeColor = 10 xx.Line.Weight = 1.2 End If Next Next Next End Sub Sub DeletingShp() Dim shp As Shape, x As Long For Each shp In ActiveSheet.Shapes If shp.Type = 1 Then shp.Delete: x = x + 1 Next shp 'MsgBox "تم حذف " & x & " دائرة بنجاح", vbMsgBoxRight, "الحمدلله" End Sub ملف الكودين للمحترم زيزو العجوز ( الكود الاول لوضع الدوائر والكود الثاني لمسح الدوائر ) نسخه منقحه الدوائر.rar

للرفع رفع الله مقداركم

جزاك الله كل خير وبارك فيك استاذ زيزو عند التجربه اصبح زر المسح لايعمل

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

للرفع رفع الله مقداركم

جزاك الله كل خير استاذ زيزو ربنا يبارك فيك ولكن عند استخدام زر المسح يتم حذف الزر نفسه ... هل من حل ؟ وهل يمكن دمج كود الدوائر مع كود المسح بمعنى عند الضغط على زر الدوائر يتم المسح اولا ثم بعدها تضاف الدوائر