ناصر سعيد

ملف الاجابه لايفتح وهذه هي الصوره

'=========================== 'هذا الكود للمحترم النابغه ياسر خليل ' الهدف من الكود هو استدعاء بشرط من خارج الكود 'وكذلك الاستدعاء بدون شرط بسطر برمجي موجود 'وقد تم التنويه داخل الكود عن السطر المسئول 'تم هذا الكود في 15/2/2017 '================== Sub استدعاء_بمعيار1() 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 Dim myArray, targt, targt1 Set Main = Sheets("المصدر") Set sh = Sheets("Sheet2") targt = sh.Range("C1").Value 'خلية البحث '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B7:AE1000").ClearContents ' عدد الصفوف في ورقة المصدر lr = Main.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Main.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, 5, 135) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) '================== 'اذا أردت ان يستدعي بيانات بشرط 'ماعليك الا ان تجعل السطر البرمجي الموجود 'اسفل هذا السطر يعمل '================== 'رقم عمود الذي سيتم البحث فيه ' If arr(i, 5) Like targt & "*" Then If arr(i, 5) = targt 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 استدعاء بيانات اعمده معينه بشرط من خارج الكود

'=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 15/2/2017 Sub استدعاء_بدون_شرط() On Error Resume Next 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("الهدف (2)") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("A7:AC10000").ClearContents ' اسم ورقة المصدر lr = ws.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها Arr = ws.Range("A7:AC" & lr).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 7, 8, 9, 23, 28, 29) 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("A7").Resize(j - 1, UBound(Temp, 2)).Value = Temp 'سطر لمسح التسطير .Range("A7:AC" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("A7:AC" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1 End With End Sub استدعاء اعمده معينه بدون شرط ويمكن ان يعمل شرط

'================ Sub Trans_Data() 'الكود خاص بالمحترم زيزو العجوز 'يحفظه الله 'تم هذا الكود في 15/11/2017 'الهدف من الكود هو استدعاء صفحة كامله بشرط '================ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'الاعلان عن اسماء الشيتات' Dim Main As Worksheet, sh As Worksheet ' الاعلان عن المصفوفتين Dim Arr As Variant, Temp As Variant '(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p ) وعداد المصفوفة الثانية Dim i As Long, j As Long, p As Long ' الاعلان عن المتغير الذى سوف يتم العمل عليه Dim dep As String Set Main = Sheets("المصدر") Set sh = Sheets("الهدف") '======= ' محو البانات القديمة sh.Range("A7:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' معيار الاختيار dep = sh.Range("C1").Value ' المصفوفة المصدر Arr = Main.Range("A7:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ابعاد المصفوفة الهدف ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' طول المصفوفة المصدر For i = 1 To UBound(Arr, 1) 'رقم عمود الشرط If Arr(i, 23) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' العداد لتحديد طول المصفوفة الهدف p = p + 1 ' عرض المصفوفة الهدف For j = 1 To UBound(Arr, 2) ' تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط Temp(p, j) = Arr(i, j) Next End If Next ' خليه البدايه لصفحه الهدف 'عرض البيانات المطلوبة If p > 0 Then sh.Range("A7").Resize(p, UBound(Temp, 2)).Value = Temp sh.Range("A7:AC" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير sh.Range("A7:AC" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _ .Weight = xlMedium ' .Weight = xlThin ' .Weight = xlMedium ' .Weight = xlThick Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub استدعاء صفحه كامله لصفحه لها نفس رؤوس الاعمده

لو اراد احد الاخوه الكرام ان يضيف كودا اخر لاثراء الموضوع فنكون شاكرين فضله

بسم الله الرحمن الرحيم احبابنا في الله ادعو الله ان تكونوا بخير وبعد : هذا ملف به اكواد جمعتها وهذبتها لتكون مرجعا لمن اراد كودا من اكواد الترحيل او الاستدعاءات *** ففيه كود استدعاء بيانات صفحه لصفحه اخرى بشرط والشرط موجود في الخليه C1 في هذه الصفحه === *** وفيه كود استدعاء اعمده معينه بدون شرط ==== وفيه كود استدعاء اعمده معينه بشرط داخل الكود === وفيه كود استدعاء اعمده معينه بشرطين من خارج الكود === وفيه كود استدعاء بيانات اعمده معينه بشرطين موجودين داخل الكود وكل كود في صفحه واسطره مشروحه حتى يسهل فهمها وتطويعها لملفاتكم جزاكم الله خيرا إدعوا لكل من كانت له بصمه في هذا العمل بالخير المرجع في الاستدعاءات والترحيل.rar

ربنا يحفظك ويصونك اخي الكريم بن عليه

بسم الله الرحمن الرحيم احبابنا في الله هذا كود خاص باستدعاء بيانات صفحه كامله الى صفحه اخرى مثلها في رؤوس العناوين ولكن بشرط - ( تصفيه بيانات ) - وهو خاص للمحترم الذي اكن له كل تقدير واحترام الاستاذ زيزو العجوز '================ Sub Trans_Data() 'الكود خاص بالمحترم زيزو العجوز 'يحفظه الله 'تم هذا الكود في 15/11/2017 'الهدف من الكود هو استدعاء صفحة كامله بشرط '================ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'الاعلان عن اسماء الشيتات' Dim Main As Worksheet, sh As Worksheet ' الاعلان عن المصفوفتين Dim Arr As Variant, Temp As Variant '(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p ) وعداد المصفوفة الثانية Dim i As Long, j As Long, p As Long ' الاعلان عن المتغير الذى سوف يتم العمل عليه Dim dep As String Set Main = Sheets("المصدر") Set sh = Sheets("الهدف") '======= ' محو البانات القديمة sh.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' معيار الاختيار dep = sh.Range("C1").Value ' المصفوفة المصدر Arr = Main.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ابعاد المصفوفة الهدف ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' طول المصفوفة المصدر For i = 1 To UBound(Arr, 1) 'رقم عمود الشرط If Arr(i, 101) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' العداد لتحديد طول المصفوفة الهدف p = p + 1 ' عرض المصفوفة الهدف For j = 1 To UBound(Arr, 2) ' تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط Temp(p, j) = Arr(i, j) Next End If Next ' خليه البدايه لصفحه الهدف 'عرض البيانات المطلوبة If p > 0 Then sh.Range("A7").Resize(p, UBound(Temp, 2)).Value = Temp sh.Range("A7:CX" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير sh.Range("A7:CX" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _ .Weight = xlMedium ' .Weight = xlThin ' .Weight = xlMedium ' .Weight = xlThick Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ========== استدعاء صفحة بشرط.rar ***************************

بسم الله الرحمن الرحيم احبابنا في الله هذا كود خاص باستدعاء بيانات صفحه كامله الى صفحه اخرى مثلها في رؤوس العناوين ولكن بشرط - ( تصفيه بيانات ) - وهو خاص للمحترم الذي اكن له كل تقدير واحترام الاستاذ زيزو العجوز '================ Sub Trans_Data() 'الكود خاص بالمحترم زيزو العجوز 'يحفظه الله 'تم هذا الكود في 15/11/2017 'الهدف من الكود هو استدعاء صفحة كامله بشرط '================ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'الاعلان عن اسماء الشيتات' Dim Main As Worksheet, sh As Worksheet ' الاعلان عن المصفوفتين Dim Arr As Variant, Temp As Variant '(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p ) وعداد المصفوفة الثانية Dim i As Long, j As Long, p As Long ' الاعلان عن المتغير الذى سوف يتم العمل عليه Dim dep As String Set Main = Sheets("المصدر") Set sh = Sheets("الهدف") '======= ' محو البانات القديمة sh.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' معيار الاختيار dep = sh.Range("C1").Value ' المصفوفة المصدر Arr = Main.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ابعاد المصفوفة الهدف ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' طول المصفوفة المصدر For i = 1 To UBound(Arr, 1) 'رقم عمود الشرط If Arr(i, 101) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' العداد لتحديد طول المصفوفة الهدف p = p + 1 ' عرض المصفوفة الهدف For j = 1 To UBound(Arr, 2) ' تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط Temp(p, j) = Arr(i, j) Next End If Next ' خليه البدايه لصفحه الهدف 'عرض البيانات المطلوبة If p > 0 Then sh.Range("A7").Resize(p, UBound(Temp, 2)).Value = Temp sh.Range("A7:CX" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير sh.Range("A7:CX" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _ .Weight = xlMedium ' .Weight = xlThin ' .Weight = xlMedium ' .Weight = xlThick Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ========== استدعاء صفحة بشرط.rar

ان شاء الله هانوصل === قم يتصغير شاشة الكود و شاشة الاكسل الى النصف تقريباً (ضعهما جانب بعضهم البعض) .. ( اقتباس ) وكيف يتم التصغير ؟ جزاك الله خيرا

الاستاذ سليم يحفظك الله ... وبعد الكود يقوم بالتصفية عن طريق Advanced filter يجب ان تكون الصفحة T_sh محددة (اي الصفحة "الهدف") 1-ادخل على صفحة الكود و قم بتعطيل الكود (حدث الصفحة) عن طريق وضع فاصلة عليا عند كل سطر من اسطره 2-ضع المؤشر داخل الكود filter_for_ME 3-بواسطة المفتاح F8 نفذ الكود خطوة خطوة و لا حظ ماذا يجري على الصفحة و ستفهم الكود يسرعة 4- بعد دراسة الكود ازل الفواصل العليا ليعود كل شيء الى طبيعته ( اقتباس ) بعد عمل ذلك تظهر الاسطر البرمجيه كل سطر ملون باللون الاصفر ومش عارف اعمل ايه تان او افهم الكود ازاي من اللون الاصفر ...

او اي فكره للتسطير تعجبك

ويبارك الله فيك ويجزيك خيرا واكثر .. استاذ محمد الدسوقي

المحترم سليم حاصبيا السلام عليكم ورحمة الله لم استطع فهم كودك لوجود اسماء خلايا اجدها فارغه مثل خليه S1 و S2 موجود ايضا a1 ابتداء المسح بالرغم من انها راس عنوان ارجو شرح الكود واضافته في ملفي هذا .. يحفظك الله استدعاء صفحة بشرط.rar

او اي فكره للتسطير تعجبك

الاستاذ زيزو السلام عليكم رحمه الله من فضلك اريد وضع هذه الاسطر البرمجيه في الكود اين اماكن وضعهم ؟ 'سطر لمسح التسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0 'سطر للتسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1 ==== مع تضبيطهم كرما منك

وعليكم السلام ورحمة الله وبركاته ربنا يحفظك ويصونك يارب

بسم الله الرحمن الرحيم احبابنا في الله هذا كود خاص باستدعاء بيانات صفحه كامله الى صفحه اخرى مثلها في رؤوس العناوين ولكن بشرط - ( تصفيه بيانات ) - وهو خاص للمحترم الذي اكن له كل تقدير واحترام الاستاذ زيزو العجوز Sub Trans_Data() 'الكود خاص بالمحترم زيزو العجوز 'يحفظه الله 'تم هذا الكود في 15/11/2017 'الهدف من الكود هو استدعاء صفحة كامله بشرط '================ 'الاعلان عن اسماء الشيتات' Dim Main As Worksheet, sh As Worksheet ' الاعلان عن المصفوفتين Dim Arr As Variant, Temp As Variant '(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p ) وعداد المصفوفة الثانية Dim i As Long, j As Long, p As Long ' الاعلان عن المتغير الذى سوف يتم العمل عليه Dim dep As String Set Main = Sheets("المصدر") Set sh = Sheets("الهدف") '======= ' محو البانات القديمة sh.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' معيار الاختيار dep = sh.Range("C1").Value ' المصفوفة المصدر Arr = Main.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ابعاد المصفوفة الهدف ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' طول المصفوفة المصدر For i = 1 To UBound(Arr, 1) 'رقم عمود الشرط If Arr(i, 101) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' العداد لتحديد طول المصفوفة الهدف p = p + 1 ' عرض المصفوفة الهدف For j = 1 To UBound(Arr, 2) ' تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط Temp(p, j) = Arr(i, j) Next End If Next ' خليه البدايه لصفحه الهدف 'عرض البيانات المطلوبة If p > 0 Then sh.Range("A7").Resize(p, UBound(Temp, 2)).Value = Temp End Sub ================== استدعاء صفحة بشرط.rar *************** ويوجد بالملف ايضا كود فلتره للمحترم الاستاذ الخلوق سليم حاصبيا ولكن لم استطع تطويع الكود في الملف فادعو الله ان يتم تطويع كوده للافاده يجزيكم الله كل خير Option Explicit Sub Filter_Me() Sheets("الهدف").Range("a8").CurrentRegion.ClearContents Sheets("المصدر").Range("a8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("الهدف").Range("m1:n2"), copytorange:=Sheets("الهدف").Range("a8") End Sub

Dim R As Long Dim X As Long Dim XX As Byte Dim ALL_LESS As String '___________________________________________ Const TOTAL As Byte = 52 'عمود المجموع Const Absent As Byte = 10 'عدد المواد لحساب الغياب Const Since As Byte = 109 'عمود مجموع العلوم Const STATUS As Byte = 101 'عمود الحالة ناجح او دور ثان Const NOTES As Byte = 102 ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر Const GENDER As Byte = 112 ' عمود الجنس ذكر او انثى '_____________________________________________________ Const LESS_ROW As Byte = 6 'صف الدرجة الصغرى Const NAM_ROW As Byte = 2 'صف اسماء المواد Const NAME_FIRST As Byte = 6 ' (اول صف لاسماء الطلاب -1) Const NAME_LAST As Long = 206 + NAME_FIRST ' عدد الطلاب '_____________________________________________________ ARR = Array(9, 18, 27, 36, 109, 54, 59, 64, 69, 78) ' اعمدة اختبار الفصل الدارسي الثاني لجميع المواد ARRY = Array(13, 22, 31, 40, 51, 57, 62, 67, 72, 82) 'اعمدة الدرجة النهائية لجميع المواد ARRYS = Array(5, 14, 23, 32, 41, 53, 58, 63, 68, 74) 'اعمدة اسماء كل المواد '_____________________________________________________ With Sheet2 'متغيراسم شيت البيانات '======================================= '*************************************** Application.ScreenUpdating = False 'الغاء تحديث الشاشة Application.Calculation = xlManual ' ايقاف الحساب التلقائي For R = NAME_FIRST To NAME_LAST ' حلقة تكرارية تبدأ بأول اسم طالب الى اخر اسم For X = 0 To UBound(ARR) ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني On Error Resume Next '____________________________________________________ 'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس 'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then XX = XX + 1 End If '____________________________________________________ 'هذا الجزء خاص بمادة العلوم تحديدا الفصل الدراسي الثاني لانه مقسم على عمودين فتم اضافة هذا الجزء ليتم معالجة هذه المرحلة If ARR(X) = Since Then 'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86 GoTo 86 'هنا يتم تخطى عمل الكود بالاسفل حتى لايتم معالجة مادة العلوم مرة اخرى Else GoTo 86 'وهنا ايضا يتم تخطى مادة العلوم الى المادة الاخرى End If End If 'هنا يتم مقارنة المواد بالدرجة الصغرى الخاصة الفصل الدارسي الثاني في اول الكود او اذا كانت غياب يتم اضافة اسم المادة من صف المواد الى المتغير 'ALL_LESS 'او مقارنة الدرجة النهائية لكل مادة بالدرجة الصغرى لها او اذا كانت غياب اذا تحقق الشرط فيتم اضافة المادة الى المتغير 'ALL_LESS '______________________________________________________ If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": 'GoTo 86 End If '_______________________________________________________ 86 Next X 'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد If .Cells(R, TOTAL) < .Cells(LESS_ROW, TOTAL) Or .Cells(R, TOTAL) = "غ" Then ALL_LESS = ALL_LESS & .Cells(NAM_ROW, TOTAL) & " لنصف الدرجة " & " - " End If 'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب If XX = Absent Then ALL_LESS = "غياب ": XX = 0 '_________________________ 'هنا بعد اكتمال الكود يتم عمل شرط للمتغير 'ALL_LESS 'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح If ALL_LESS = "" Then If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "ناجح " 'اذا كان نوع الطالب ذكر يتم وضع ناجح If .Cells(R, GENDER) = "انثى" Then .Cells(R, STATUS) = "ناجحة " 'اذا كانت انثى يتم وضع ناجحه If .Cells(R, GENDER) = "ذكر" Then .Cells(R, NOTES) = "ومنقول " & INFO.Range("B14") 'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو If .Cells(R, GENDER) = "انثى" Then .Cells(R, NOTES) = "ومنقولة " & INFO.Range("B14") 'مثل ماسبق 'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان ElseIf ALL_LESS <> "" Then If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "له دور ثان في" 'مثل ما سبق بخصوص النوع If .Cells(R, GENDER) = "انثى" Then .Cells(R, STATUS) = "لها دور ثان في" ' .Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2) 'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات ALL_LESS = Empty 'تفريغ المتغير لاعادة تعبئة اسم طالب اخر End If '_____________________________________________________ Next R 'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب End With Application.ScreenUpdating = True 'اعادة تحديث الشاشة Application.Calculation = xlAutomatic 'تشغيل الحساب التلقائي End Sub استخراج حالة الطالب ومواد الرسوب نسخه منقحه .rar ================== في بدايه الكود نضع Sub YASSER_ELARABY() 'تم هذا الكود بواسطه المحترم ياسر العربي 'فائده هذا الكود هو استخراج حاله الطالب من 'ناجح او دور تان وكذلك استخراج مواد الدور لتاني 'تم في 28/8/2016

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

الاستاذ المحترم زيزو العجوز يحفظك الله ويرعاك ارجو وضع شرح لاكوادك دائما لانها مراجع يستفيد منها الكثيرون ونتعلم منها ==== اين الجزئيه التي تجعلنا نغير في بدايه وضع النتائج في صفحة الهدف وكذلك في صفحه المصدر بارك الله فيك ======= Sub TransData() Dim Main As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Dim dep As String Set Main = Sheets("المصدر") Set sh = Sheets("الهدف") '======= sh.Range("A2:J" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents dep = sh.Range("L1").Value Arr = Main.Range("A2:J" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 4) = dep Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then sh.Range("A2").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

========================= الملف الجامع لهذه الاكواد ( اكواد الاستدعاء ) استدعاء بمعيارين من الخارج3.rar

الله يرحمك ويحسن اليك .. بحق الله يدخلك فسيح جناته كنت حقا فارسا للاكسيل وخلوقا الله يرحمك استاذ الحسامي لم تغلق اعمالك وتركتها لنا مفتوحه لنتعلم وندعو لك Sub Macro1() SpreadsheetPassword = 123 ActiveSheet.Unprotect Password:=SpreadsheetPassword Rows("10:15").EntireRow.Hidden = True ActiveSheet.Protect Password:=SpreadsheetPassword, UserInterfaceOnly:=True ActiveSheet.EnableOutlining = True End Sub Sub Macro2() SpreadsheetPassword = 123 ActiveSheet.Unprotect Password:=SpreadsheetPassword Rows("10:15").EntireRow.Hidden = False ActiveSheet.Protect Password:=SpreadsheetPassword, UserInterfaceOnly:=True ActiveSheet.EnableOutlining = True End Sub كود الحسامي رحمة الله عليه

********************************* '=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'وكذلك الاستدعاء بدون شرط بسطر برمجي جديد 'وقد تم التنويه داخل الكود عن السطر المسئول 'تم هذا الكود في 15/2/2017 '================== Sub استدعاء_بمعيار1() 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 Dim myArray, targt, targt1 Set Main = Sheets("المصدر") Set sh = Sheets("Sheet2") targt = "ذكر*" 'خلية البحث '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B7:AE1000").ClearContents ' عدد الصفوف في ورقة المصدر lr = Main.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Main.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, 5, 135) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) '================== 'اذا أردت ان يستدعي بيانات بشرط 'ماعليك الا ان تجعل السطر البرمجي الموجود 'اسفل هذا السطر يعمل '================== 'رقم عمود الذي سيتم البحث فيه If arr(i, 5) Like targt & "*" 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 '=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 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("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, 5, 135) 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