ناصر سعيد

جزاك الله خير ا ... ونرجو من الله ان يبارك لك ونرجو متابعه آراء الاخوه في البرنامج حتى تستطيع ان تجعله افضل برنامج

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

Sub Yasser_Serch() Dim myArray, lr, X, targt, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("Sheet2") 'اسم شيت قاعدة البيانات Set SERCH = Worksheets("Sheet1") 'اسم الشيت الخاص بالبحث '____________________________________________ lr = DATA.Cells(Rows.Count, 1).End(xlUp).Row 'اخر صف به بيانات SERCH.Range("L4:U" & SERCH.Cells(Rows.Count, 12).End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم targt = SERCH.Range("e1").Value 'خلية البحث targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), DATA.Range("A1:J1"), 0) 'دالة لايجاد رقم عمود البحث myArray = DATA.Range("A2:J" & lr + 1) 'نطاق قاعدةالبيانات الذي سيتم البحث فيه '____________________________________________ ReDim y(1 To UBound(myArray, 1), 1 To UBound(myArray, 2)) For X = LBound(myArray) To UBound(myArray) If targt = "" Then Exit Sub If myArray(X, targtN) Like targt & "*" Then rw = rw + 1 For yy = 1 To 10 y(rw, yy) = myArray(X, yy) Next yy End If Next X '____________________________________________________________________________________ If rw > 0 Then SERCH.Cells(Rows.Count, 12).End(xlUp)(2, 1).Resize(rw, 10).Value = y() 'التعديل بهذا السطر تقوم بتغيير رقم العمودالمراد '____________________________________________________________________________________ End Sub وهذا يوضع في موديول Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$1" Then Call Yasser_Serch End If End Sub هذا الكود يوضع في حدث الورقه خاص بالبحث وهذا هو المرفق Range("L4:U4").AutoFill _ Destination:=Range("L4:U4" & _ Range("A1").Value + 6), Type:=xlFillDefault Sub Yasser_Serch() Dim myArray, lr, X, targt, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("Sheet2") 'اسم شيت قاعدة البيانات Set SERCH = Worksheets("Sheet1") 'اسم الشيت الخاص بالبحث '____________________________________________ lr = DATA.Cells(Rows.Count, 1).End(xlUp).Row 'اخر صف به بيانات SERCH.Range("L4:U" & SERCH.Cells(Rows.Count, 12) _ .End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم Range("L4:U4").AutoFill _ Destination:=Range("L4:U4" & _ Range("A1").Value + 6), Type:=xlFillDefault targt = SERCH.Range("e1").Value 'خلية البحث targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), DATA.Range("A1:J1"), 0) 'دالة لايجاد رقم عمود البحث myArray = DATA.Range("A2:J" & lr + 1) 'نطاق قاعدةالبيانات الذي سيتم البحث فيه '____________________________________________ ReDim y(1 To UBound(myArray, 1), 1 To UBound(myArray, 2)) For X = LBound(myArray) To UBound(myArray) If targt = "" Then Exit Sub If myArray(X, targtN) Like targt & "*" Then rw = rw + 1 For yy = 1 To 10 y(rw, yy) = myArray(X, yy) Next yy End If Next X '____________________________________________________________________________________ If rw > 0 Then SERCH.Cells(Rows.Count, 12).End(xlUp)(2, 1).Resize(rw, 10).Value = y() 'التعديل بهذا السطر تقوم بتغيير رقم العمودالمراد '____________________________________________________________________________________ End Sub به اضافه مفيده وهي نسخ الصف الاول من الجدول بالعدد الذي تبغاه الله يحفظك ياستاذ ياسر العربي

اريد من احد الافاضل تحويل الملف الى 2003 كرما منكم

جزاكم الله خيرا

أرجو معرفة كيفية زيادة عدد الأعمدة في موضوع المصفوفات وشكرا جزاكم الله خيرا في صفحه الهدف وليس صفحه المصدر

Option Explicit Sub Araby_Search() 'تعريف المتغير لورقة العمل التي تحتوي على البيانات الخام Dim wsData As Worksheet 'تعريف المتغير لورقة العمـل المطلـوب إظهـار النتائـج بها Dim wsResult As Worksheet 'تعريف المتغير ليحمل قيم المصفـوفة للبيانات الخـام Dim Arr As Variant 'تعريف المتغير ليحمل قيم المصفوفة للنتائج المطلوبة Dim Temp As Variant 'تعريـف المتغير من النـوع النصي ليحمـل قيمة أو نص البحث 'أي الكلمة المطلوب البحث عنها يتم تخزينها في هذا المتغير Dim strSearch As String 'تعريف المتغير وسيستخدم في الحلقة التكرارية لصفوف المصفوفة Dim I As Long 'تعريف المتغير وسيستخدم في الحلقة التكرارية لأعمدة المصفوفة Dim J As Long 'تعريف المتغير وسيستخدم في مصفوفة النتائج لزيادة مقدار الصفوف بمقدار واحد Dim P As Long 'تعيين قيمة للمتغير ليساوي ورقة العمل التي تحتوي '[Data] على البيانات الخام المطلوب معالجتها والمسماة Set wsData = Worksheets("Data") 'تعيين قيمة للمتغير ليساوي ورقة العمل التي تريد إظهار '[G2] النتائج بها بمجرد إدخال قيمة أو نص محدد في الخلية Set wsResult = Worksheets("Result") 'مسح النطاق الذي توضع فيه النتائج استعداداً لوضع النتائج الجديدة wsResult.Range("A8:N10000").ClearContents '[G2] تعيين قيمة للمتغير ليساوي قيمة الخلية 'وهي الخلية التي ستوضع فيها نص الكلمة المطلوب البحث عنها strSearch = wsResult.Range("G2").Value 'تعيين قيمـة للمتغير ليحمل قيم النطاق بالكامل للبيانات الخام ' وذلك [Data] حيث أن مصـدر البيانات الخام ورقة العمل المسماة 'عند [N] وينتهي في العمود [A5] في النطاق الذي يبدأ من الخلية '[&] آخـر صف به بيانات ، ويتم تحديده عن طريـق الجزء بعد علامـة Arr = wsData.Range("A5:N" & wsData.Cells(Rows.Count, 1).End(xlUp).Row).Value 'والتي ستحمل قيم النتائج [Temp] إعادة تعيين أبعاد المصفوفة المسماة '[Arr] وتكون بنفس أبعاد المصفوفة التي تحمل البيانات الخام والمسماة 'سنعتبر المصفوفة أشبـه بالصفـوف والأعمدة حيث الرقـم 1 يمثـل الصفـوف 'بإرجاع أكبر قيمة [UBound]بينما الرقم 2 يمثل الأعمدة ، وتقوم الكلمة 'أبعاد المصفوفة في هذه الحالة >> '------------------------------- 'البعد الأول سيكون من 1 إلى أكبر قيمة للصفوف 'البعد الثاني سيكون من 1 إلى أكبر قيمة للأعمدة ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) 'حلقة تكرارية من الصف الأول للمصفوفة إلى آخر صف بها For I = 1 To UBound(Arr, 1) 'إذا كان النص المطلوب البحث عنه فارغ يتم الخروج من تنفيذ الكود If strSearch = "" Then Exit Sub 'هذا السطر هو أهم سطر بالكود حيث هو الشرط الذي من خلاله 'والشرط [Temp] ستوضع النتائج في مصفوفة النتائج المسماة 'هـو تطابق قيمة المصفوفة في صف الحلقة في العمود رقم 14 'حيث يمثـل الرقم 14 العمود داخـل مصفوفة البيانات الخام '[strSearch] يتـم اختبـار التطابـق مع نـص البحث المسمى If Arr(I, 14) Like "*" & strSearch & "*" Then 'زيادة مقدار المتغير بمقدار 1 'فائدة المتغير هنا هو أنه مع كل حلقة تكرارية 'إذا تحقق الشرط فقط يزيد المتغير بمقدار واحد 'ليمثل هذا المتغير صفوف مصفوفة النتائج الجديدة P = P + 1 'حلقة تكرارية داخلية من العمود الأول للمصفوفة إلى آخر عمود بها For J = 1 To UBound(Arr, 2) 'تعبئـة مصفـوفة النتائـج بالبيانات مـن مصفوفة البيانات الخام '[Temp]مثـال لتتضح صورة كيفية تعبئة المصفوفة الجديدة المسماة 'في أول حلقـة سيكون مقداره 1 ويمثل أول صف [P] المتغيـر المسمى 'أول صف هنا لمصفوفة النتائج 'في أول حلقة سيكون مقداره 1 ويمثل أول عمود [J] المتغير المسمى 'في أول حلقة سيكون مقداره 1 ويمثل أول صف [I] المتغير المسمى 'أول صف هنا لمصفوفة البيانات الخام Temp(P, J) = Arr(I, J) 'الانتقال للحلقة التالية للأعمدة Next J 'نهاية جملة الشرط وهو تطابق نص البحث مع العمود رقم 14 في المصفوفة End If 'الانتقال للحلقة التالية في صفوف مصفوفة البيانات الخام Next I 'إذا كانت قيمة المتغير أكبر من صفر فهذا يعني أنه تم إيجاد نتائج للبحث 'حيث أن زيادة المتغير كما أوضحنا مقرونة بتحقق الشرط وطالما تحقق الشرط 'فهذا يعني أن مصفوفة النتائج سيكون بها بيانات ومن ثم يتحقق الجزء الثاني '[A8] وضع نتائج مصفوفة النتائج في أول خلية في ورقة النتائج في الخلية '[P] ويتم تمديد النطاق بمقدار عدد الصفوف طبقاً لقيمة المتغير المسمى '[Temp] وبمقدار عدد الأعمدة طبقاً لأكبر عدد لأعمدة المصفوفة المسماة If P > 0 Then wsResult.Range("A8").Resize(P, UBound(Temp, 2)).Value = Temp End Sub ربنا يكتبها في كفه حسنات المحترم ياسر

http://www.mediafire.com/file/ynyjqa2nzwt/Fonts+Arabi_By_safwan.rar رابط جديد للاسطوانه الرائعه http://www.mediafire.com/file/ynyjqa2nzwt/Fonts+Arabi_By_safwan.rar

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

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

لو سمحتم نسخه 2003

يتم الاستدعاء ولكن من الصف السابق للصف المرغوب فيه يعني انا عايز يبدا من الصف ال7 ولكن الاستدعاء يبدا من الصف 6

المحترم العبقري ياسر ابو العربي اريد استدعاء بيانات في كشف الناجحين والراسبين وجزاكم الله خيرا ترحيل الدور التاني5.rar

شرح الحبيب الغالي ياسر للكود المميز http://up.top4top.net/downloadf-3295bbxd1-rar.html جزاه الله كل خير

جزاكم الله خيرا ... نريد نسخه 2003 كرما منكم

Sub Yasser_Serch() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 8 / 10/ 2016 ''الهدف من الكود هو فلترة البيانات ''شرح الكود '' Dim myArray, lr, X, targt, targt1, targt2, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("رصد الترم الثانى") 'اسم شيت قاعدة البيانات Set SERCH = Worksheets("بيانات الطلبة (2)") 'اسم الشيت الخاص بالبحث '____________________________________________ Range("A8:R1000").Clear Range("A7:R7").AutoFill Destination:=Range("A7:R" & Range("A4").Value + 6), Type:=xlFillDefault lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2 'اخر صف به بيانات SERCH.Range("B7:N" & SERCH.Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم targt = "له* دور ثان في" 'خلية البحث myArray = DATA.Range("A7:EF" & lr) 'نطاق قاعدةالبيانات الذي سيتم البحث فيه '____________________________________________ ReDim Y(1 To lr, 1 To 13) For X = 1 To lr - 6 If targt = "" Then Exit Sub If myArray(X, 101) Like targt & "*" Then rw = rw + 1 'For ww = 1 To 102 ' Y(rw, ww) = myArray(X, ww) ' Next ww Y(rw, 1) = myArray(X, 2) Y(rw, 2) = myArray(X, 1) Y(rw, 3) = myArray(X, 3) Y(rw, 4) = myArray(X, 109) Y(rw, 5) = myArray(X, 131) Y(rw, 6) = myArray(X, 132) Y(rw, 7) = myArray(X, 133) Y(rw, 8) = myArray(X, 134) Y(rw, 9) = myArray(X, 135) Y(rw, 10) = myArray(X, 136) Y(rw, 11) = myArray(X, 108) Y(rw, 12) = myArray(X, 110) Y(rw, 13) = myArray(X, 111) End If Next X If rw > 0 Then SERCH.Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(rw, 13).Value = Y() End Sub =COUNTIF('رصد الترم الثانى'!CW7:CW137;"له* دور ثان في")

هل يمكن اضافه .... الاسطر تتم بعدد الطلاب اللي موجود في خليه عدد الطلاب ؟ هانعمل معادله في خليه عدد الطلاب تجيب عدد الطلاب الذين لهم دور تان من صفحه رصد الترم التاني-

حفظك ربنا ورعاك خليفه العلامه عبد الله باقشير الاستاذ ياسر العربي اسرع كود شوفته

بسم الله الرحمن الرحيم احبابنا في الله هذا ملف اريد ترحيل طلاب الدور التاني وجزاكم الله كل خير ترحيل الدور التاني.rar

المحترم الاستاذ منير انت قمه ربنا يبارك فيك نرجو نسخه 2003 كرما منكم

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

لماذا يا اخي الكريم لم تضع الباسوورد ؟ انت تعلم جيدا ان المنتدى تعليمي ولو دام العلم لغيرك ماوصل لك تقبل تحياتي ودعواتي الطيبه

جزاك الله كل خير وبارك فيك نرجو امدادنا بكلمات السر فضلا منك

Sub Yasser_Serch() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 8 / 10/ 2016 ''الهدف من الكود هو فلترة البيانات ''شرح الكود '' Dim myArray, lr, X, targt, targt1, targt2, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("رصد الترم الثانى") 'اسم شيت قاعدة البيانات Set SERCH = Worksheets("الحاله") 'اسم الشيت الخاص بالبحث '____________________________________________ lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2 'اخر صف به بيانات SERCH.Range("A10:CX" & SERCH.Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم targt = SERCH.Range("e2").Value 'خلية البحث myArray = DATA.Range("A7:CX" & lr) 'نطاق قاعدةالبيانات الذي سيتم البحث فيه '____________________________________________ ReDim Y(1 To lr, 1 To 102) For X = 1 To lr - 6 If targt = "" Then Exit Sub If myArray(X, 101) Like targt & "*" Then rw = rw + 1 For ww = 1 To 102 Y(rw, ww) = myArray(X, ww) Next ww End If Next X If rw > 0 Then SERCH.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 102).Value = Y() End Sub الاستاذ ياسر العربي السلام عليكم ورحمة الله وبركاته ارجو اضافه شرح لاسطر الكود حتى يكون مرجعا للجميع جزاك الله خيرا

فضلك الله بالجنه ياخليفه الغلامه عبد الله باقشير