اذهب الي المحتوي
أوفيسنا

كود استدعاء بمعيار واحد وبمعيارين


الردود الموصى بها

ولااروع سهولة في التطبيق .. سرعه في التنفيذ

كود استدعاء للمبدع ياسر العربي

Sub ALL()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 8 / 10/ 2016
''الهدف من الكود هو استدعاء البيانات
''شرح الكود
''متغيرات
    Dim myArray, lr, X, targt, targt1, targt2, targtN

    Dim SERCH As Worksheet, _
    DATA As Worksheet
    '____________________________________________

    'اسم شيت قاعدة البيانات
    Set DATA = Worksheets("رصد الترم الثانى")

    'اسم الشيت الخاص بالبحث
    Set SERCH = Worksheets("كشوف الطلبه")
    '____________________________________________
    'المدى الذي سيتم مسحه في صفحه الهدف
    Range("D10:AB1000").Clear

    'المدى الذي سيتم نسخه لعدد محدد بخليه محدده
    Range("C9:AB9").AutoFill _
     Destination:=Range("C9:AB" & _
 Range("B4").Value + 8), Type:=xlFillDefault

    'اخر صف به بيانات
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2


    'مدى صفحة الهدف وهو يبدأ بعد عمود المسلسل
    'والرقم الموجود هو رقم عمود البدايه
    ' 'مسح نطاق البحث القديم
    SERCH.Range("D9:AB" & SERCH.Cells(Rows.Count, 4) _
                .End(xlUp).Row + 1).ClearContents

    'معيارين البحث
          '  targt2 = targt
    targt = "له* دور ثان في"
    targt2 = "ناجح"
    'نطاق قاعدةالبيانات
    ' صفحة المصدرالذي سيتم البحث فيه
    myArray = DATA.Range("A7:FF" & lr)
    '____________________________________________

   
   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, 101) Like targt & "*" _
  Or myArray(X, 101) Like targt2 & _
  "*" Then
                rw = rw + 1
                
           'متغير ارقام
    'الاعمده المطلوب الاستدعاء منها
   'العمود التاني بعد المسلسل
          Y(rw, 1) = myArray(X, 2)
          
              'العمود الثالث بعد المسلسل
          Y(rw, 2) = myArray(X, 3)
          
              'العمود الرابع بعد المسلسل
          Y(rw, 3) = myArray(X, 13)
          
              'العمود الخامس بعد المسلسل
          Y(rw, 4) = myArray(X, 22)
          
              'العمود السادس بعد المسلسل وهكذا
          Y(rw, 5) = myArray(X, 31)
          
          Y(rw, 6) = myArray(X, 40)
          Y(rw, 7) = myArray(X, 51)
          Y(rw, 8) = myArray(X, 52)
          Y(rw, 9) = myArray(X, 82)
          Y(rw, 10) = myArray(X, 101)
          Y(rw, 11) = myArray(X, 102)
        '  Y(rw, 12) = myArray(X, 110)
         ' Y(rw, 13) = myArray(X, 111)
        End If
Next X
If rw > 0 Then SERCH.Cells(Rows.Count, 4).End(xlUp)(2, 1).Resize(rw, 13).Value = Y()
End Sub

 

الاستدعاء بطريقه ( خليفه عبد الله باقشير ) الاستاذ ياسر.rar

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

================================================

عفوا .. عندما تقرأ الموضوع وتريد ان تشارك بمشاركه

اجعل مقاس الخط 26 

لون الخط بلون غامق

اجعل كتاباتك في وسط الصفحة

وشكرا لتفاعلكم

 

رابط هذا التعليق
شارك

مشكور اخي الكريم ناصر على موضوعك هذا 

والفضل لك ايضا في تعديلك وتشكيلك للكود ليناسب احتياجاتك

زادكم الله علما وجزيت خيرا

تقبل تحياتي

:fff:

  • Like 1
رابط هذا التعليق
شارك

  • 2 weeks later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information