ناصر سعيد

بسم الله الرحمن الرحيم اخواني في الله هذا ملف جامع لموضوع استدعاء البيانات من اعمده مختلفه بمعايير مختلفه من المحترم الاستاذ النشط ياسر خليل حفظه الله استدعاء بمعيارين من الخارج3.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 Dim myArray, targt, targt2 Set Main = Sheets("المصدر") Set sh = Sheets("Sheet2") targt = sh.Range("C1").Value & "*" targt2 = sh.Range("C2").Value & "*" 'targt = "ذك*" 'targt2 = "نا*" '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه 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 & "*" _ And arr(i, 135) Like targt2 & "*" 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

جزاك الله خيرا استاذ محمد وجعل الله هذا العمل في كفة حسناتك ====================== رابط اخر ادعوا لنا ربنا يبارك لكم https://up.top4top.net/downloadf-674hmsqn1-rar.html __________________

كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub

Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

Sub SortData() Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي

'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرطين 'وكذلك الاستدعاء بدون شرط 'وقد تم التنويه داخل الكود عن السطر المسئول '=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرطين 'وكذلك الاستدعاء بدون شرط 'وقد تم التنويه داخل الكود عن السطر المسئول 'تم هذا الكود في 15/2/2017 '================== Sub Tarheeel() 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 targt = "ذك*" targt2 = "أنث*" Set Main = Sheets("رصد الترم الأول") Set sh = Sheets("كشوف الترم الأول") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه 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, 6, 78, 9, 79, 12, 80, _ 15, 81, 20, 82, 21, 83, 22, 84, 24, 85, _ 25, 86, 87, 87) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) '================== 'اذا أردت ان يستدعي بيانات بدون شرط 'ماعليك الا ان تجعل السطر البرمجي الموجود 'اسفل هذا السطر لا يعمل '================== 'رقم عمود الذي سيتم البحث فيه If arr(i, 74) Like targt & "*" _ Or arr(i, 74) Like targt2 & "*" 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 Tarheeel() 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 targt = "ذكر*" 'خلية البحث Set Main = Sheets("رصد الترم الأول") Set sh = Sheets("كشوف الترم الأول") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه 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, 6, 78, 9, 79, 12, 80, _ 15, 81, 20, 82, 21, 83, 22, 84, 24, 85, _ 25, 86, 87, 87) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) '================== 'اذا أردت ان يستدعي بيانات بشرط 'ماعليك الا ان تجعل السطر البرمجي الموجود 'اسفل هذا السطر يعمل '================== 'رقم عمود الذي سيتم البحث فيه If arr(i, 74) 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 Tarheeel() 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 Main = Sheets("رصد الترم الأول") Set sh = Sheets("كشوف الترم الأول") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B8: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, 6, 78, 9, 79, 12, 80, _ 15, 81, 20, 82, 21, 83, 22, 84, 24, 85, _ 25, 86, 87, 87) 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

جزاك الله كل خير وبارك فيك

جزاك الله خيرا وبارك فيك

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

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

جزاك الله خيرا وبارك فيكم

هل هذه الاسطر سليمه واين توضع في الكود ؟ جزاكم الله خيرا If targt1 Or targt2 Or targt3 = "" Then MsgBox "لايوجد طلاب او البيانات غير مكتمله " Exit Sub End If

بسم الله الرحمن الرحيم جزاكم الله خيرا هذا كود رائع .. ولكن نريد اضافه سطر يعطي رساله للمستخدم في حاله عدم وجود بيانات بانه لايوجد بيانات Sub اربعشهادات_بثلاث_معايير() 'هذا الكود للنابغه ساجده العزاوي ' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه 'تم في اكتوبر 2017 'كمعطيات المحترم ابو أحمد محمدي 'تم التعديل على الكود لمتطلبات جديده بواسطه المحترم ذائع الصيت بن علية حادجي الجزائري 'تم بناء على متطلبات جديده في الكود 'الهدف من الكود هو استخراج الشهادات 'كل 3 شهادات في صفحه واحدة 'بثلاثة معايير '====================== Dim SHEHADA As Worksheet, DATA As Worksheet Dim myArray, targt1, targt2, targt3 As String Dim X, Y, Z, U, V As Long 'اسم صفحة المصدر Set DATA = Worksheets("رصد الترم الثانى") 'اسم صفحة الهدف Set SHEHADA = Worksheets("4شهادات بثلاث معايير") '====================== ' targt1 = "ناج*" ' targt2 = "ول*" ' targt3 = "5/1" targt1 = SHEHADA.Range("R7").Value & "*" targt2 = SHEHADA.Range("S7").Value & "*" targt3 = SHEHADA.Range("T7").Value & "*" '====================== c = 0 Application.ScreenUpdating = False lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row 'اخر صف به بيانات '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! X = SHEHADA.Range("T1").Value Y = SHEHADA.Range("R1").Value Z = SHEHADA.Range("S1").Value U = IIf(X = 1, 7, Y) V = IIf(X = 1, lr, Z) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 'هذا السطر في حال كل الشهادات أو شهادات محددة For i = U To V '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! If DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 0 Then Range("M3") = DATA.Cells(i, 2) c = c + 1 '====================== ElseIf DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 1 Then Range("M19") = DATA.Cells(i, 2) c = c + 1 '====================== ElseIf DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 2 Then Range("M35") = DATA.Cells(i, 2) c = c + 1 '====================== ElseIf DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 3 Then SHEHADA.Range("M51") = DATA.Cells(i, 2) c = c + 1 '====================== End If '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! If i = V And c = 4 Then SHEHADA.Range("a1:p63").PrintOut: Exit For If i = V And c = 3 Then SHEHADA.Range("a1:p47").PrintOut: Exit For If i = V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut: Exit For If i = V And c = 1 Then SHEHADA.Range("a1:p15").PrintOut: Exit For If i < V And (Range("M19") = "" Or Range("M35") = "" Or SHEHADA.Range("M51") = "") Then GoTo 1 If i < V And c = 4 Then SHEHADA.Range("a1:P63").PrintOut '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c = 0 SHEHADA.Range("M3") = "" SHEHADA.Range("M19") = "" SHEHADA.Range("M35") = "" SHEHADA.Range("M51") = "" 1: Next i SHEHADA.Range("M3") = "" SHEHADA.Range("M19") = "" SHEHADA.Range("M35") = "" SHEHADA.Range("M51") = "" Application.ScreenUpdating = True End Sub ========================= هل هذه الاسطر سليمه واين توضع في الكود ؟ If targt1 Or targt2 Or targt3 = "" Then MsgBox "لايوجد طلاب او البيانات غير مكتمله " Exit Sub End If

سادة الأفاضل العاملين فى التربية والتعليم السلام عليكم ورحمة الله وبركاته ------------------------------------------------------------ كم يسعدنى أن أقدم لكم أول برنامج كنترول مدرسى فى مصر بأحدث التعديلات الوزارية بعد القرار 377 لسنة 2017 م ..... اضغط ( عرض المزيد ) لقراءة المنشور كاملا وتحميل روابط البرنامج ------------------------------------------------------------ وعليه فيتم إيقاف العمل بالنسخة السابق إصدارها بتاريخ 14/10/2017م قبل التعديل ------------------------------------------------------------ و إليكم روابط تحميل آخر تحديث بتاريخ اليوم 4/11/2017 م ------------------------------------------------------------ كل الصفوف لوكشة واحدة ( لأصحاب النت السريع ) http://www.mediafire.com/…/%D9%83%D9%84_%D8%A7%D9%84%D8%B5%… الصف الأول http://www.mediafire.com/…/%D8%A7%D9%84%D8%B5%D9%81_%D8%A7%… الصف الثانى http://www.mediafire.com/…/%D8%A7%D9%84%D8%B5%D9%81_%D8%A7%… الصف الثالث http://www.mediafire.com/…/%D8%A7%D9%84%D8%B5%D9%81_%D8%A7%… الصف الرابع http://www.mediafire.com/…/%D8%A7%D9%84%D8%B5%D9%81_%D8%A7%… الصف الخامس http://www.mediafire.com/…/%D8%A7%D9%84%D8%B5%D9%81_%D8%A7%… الصف السادس http://www.mediafire.com/…/%D8%A7%D9%84%D8%B5%D9%81_%D8%A7%… تعليمات التشغيل http://www.mediafire.com/…/%D8%AA%D8%B9%D9%84%D9%8A%D9%85%D… تفعيل ماكرو 2010 http://www.mediafire.com/…/%D8%AA%D9%81%D8%B9%D9%8A%D9%84_%… ------------------------------------------------------------ برجاء سرعة تفقد البرنامج وملاحظة أى أخطاء أو سهو فيه للتعديل إن وجد وإن شاء الله قلما توجد به أخطاء إلا عن طريق السهو وهذه هى صورة الواجهة الجديدة للتعديلات =============== رابط كمان لاخر اصدار بتاريخ 4/11/2017 هديه الاستاذ محمد الدسوقي و للاستاذ ياسر https://up.top4top.net/downloadf-674hmsqn1-rar.html

Sub بمعيارين() ' هذا الكود للنابغه ساجده العزاوي ' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه 'تم في اكتوبر 2017 'كمعطيات المحترم ابو أحمد محمدي 'الهدف من الكود هو استخراج الشهادات 'كل شهادتين في صفحه واحدة 'بثلاث معايير '====================== Dim SHEHADA As Worksheet, DATA As Worksheet Dim myArray, targt1, targt2, targt3 As String Dim X, Y, Z, U, V As Long 'اسم صفحة المصدر Set DATA = Worksheets("رصد الترم الثانى") 'اسم صفحة الهدف Set SHEHADA = Worksheets("شهادتين") '====================== ' targt1 = "ناج*" ' targt2 = "ول*" ' targt3 = "5/1" targt1 = SHEHADA.Range("R7").Value & "*" targt2 = SHEHADA.Range("S7").Value & "*" targt3 = SHEHADA.Range("T7").Value & "*" '====================== c = 0 Application.ScreenUpdating = False lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row 'اخر صف به بيانات '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! X = SHEHADA.Range("T1").Value Y = SHEHADA.Range("R1").Value Z = SHEHADA.Range("S1").Value U = IIf(X = 1, 7, Y) V = IIf(X = 1, lr, Z) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 'هذا السطر في حال كل الشهادات أو شهادات محددة For i = U To V '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! If DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 0 Then Range("M3") = DATA.Cells(i, 2) c = c + 1 '====================== ElseIf DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 1 Then Range("M19") = DATA.Cells(i, 2) c = c + 1 '====================== 'ElseIf DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ 'And c = 2 Then 'Range("M35") = DATA.Cells(i, 2) ' c = c + 1 '====================== 'ElseIf DATA.Cells(i, 101) Like targt1 & "*" _ And DATA.Cells(i, 104) Like targt2 & "*" _ And DATA.Cells(i, 103) Like targt3 & "*" _ And c = 3 Then ' SHEHADA.Range("M51") = DATA.Cells(i, 2) ' c = c + 1 '====================== End If '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 'If i = V And c = 4 Then SHEHADA.Range("a1:p63").PrintOut: Exit For ' If i = V And c = 3 Then SHEHADA.Range("a1:p47").PrintOut: Exit For If i = V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut: Exit For If i = V And c = 1 Then SHEHADA.Range("a1:p15").PrintOut: Exit For If i < V And (Range("M3") = "" Or Range("M19") = "") Then GoTo 1 If i < V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c = 0 SHEHADA.Range("M3") = "" SHEHADA.Range("M19") = "" ' SHEHADA.Range("M35") = "" ' SHEHADA.Range("M51") = "" 1: Next i SHEHADA.Range("M3") = "" SHEHADA.Range("M19") = "" ' SHEHADA.Range("M35") = "" ' SHEHADA.Range("M51") = "" Application.ScreenUpdating = True End Sub كل شهادتين في صفحه واحدة

راائع يحفظك الخالق يارب اخي المحترم بن عليه