اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

VBA استدعاء بتحقق شرطين


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

السلام عليكم اخواني الكرام

ارجو المساعدة في الملف المرفق بحيث يتم استدعاء معلومات عن طريق كود برمجي vba  بتحقق شرطين ( اسم المستخدم والتاريخ ) ،  يفضل اسرع كود برمجي لان العملية سوف تتم ل31 يوم ول 73 الي 100 موظف .الشرح بالمرفق

sample.rar

تم تعديل بواسطه عبدالله ياسين
تم ادراج الموضوع خطاً
رابط هذا التعليق
شارك

جرب هذا الماكرو

Sub Copy_Data()
Application.ScreenUpdating = False
Dim ws1, ws2, ws3 As Worksheet
Set ws1 = Sheets("Main"): Set ws2 = Sheets("Actual Login logout") _
: Set ws3 = Sheets("Scheduled Data")
Dim Foundcel2, Foundcel3 As Range
Dim R2, R3 As Integer
Dim Lr1, Lr2, Lr3  As Integer
Dim Cel As Range
Dim Count_data2, Count_data3 As Integer
Dim My_Rg1, My_Rg2, My_Rg3 As Range
Lr1 = ws1.Cells(Rows.Count, 1).End(3).Row: Set My_Rg1 = ws1.Range("b2:b" & Lr1)
Lr2 = ws2.Cells(Rows.Count, 1).End(3).Row: Set My_Rg2 = ws2.Range("a2:a" & Lr2)
Lr3 = ws3.Cells(Rows.Count, 1).End(3).Row: Set My_Rg3 = ws3.Range("a2:a" & Lr3)
ws1.Select
ActiveSheet.Range("c2:f" & Lr1).ClearContents
For Each Cel In My_Rg1

  Count2 = Application.CountIf(My_Rg2, Cel): Count3 = Application.CountIf(My_Rg3, Cel)

 If Count2 + Count3 <> 2 Then GoTo 1
     Set Foundcel2 = My_Rg2.Find(what:=Cel): R2 = Foundcel2.Row
     Set Foundcel3 = My_Rg3.Find(what:=Cel): R3 = Foundcel3.Row
     Cel.Offset(0, 1) = ws2.Cells(R2, 4): Cel.Offset(0, 2) = ws2.Cells(R2, 5)
     Cel.Offset(0, 3) = ws3.Cells(R3, 4): Cel.Offset(0, 4) = ws3.Cells(R3, 5)
1:
Next
Application.ScreenUpdating = True
End Sub

 

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

3 ساعات مضت, عبدالله ياسين said:

شكرا اخي الكريم لاكن لم يعمل معي الكود ،فلم تظهر اي نتائج في القائمة الرئيسية.

انظر الى المرفق كنموذج من 20 اسم

 

sample salim.rar

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

شكرا اخي سليم لاكن الكود لايعمل عند تطبيقه على نموذج ااكثر من 20 اسم والغرض من اللبرنامج هو تحديث البيانات لشهر كامل ل100 موظف ، الكود البرمجي لايعمل على المثال المرفق من قبلي لانه يحتوي على بيانات  اكثر من ال 20 اسم . شكرا لك على المساعدة .

 

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

7 دقائق مضت, عبدالله ياسين said:

شكرا اخي سليم لاكن الكود لايعمل عند تطبيقه على نموذج ااكثر من 20 اسم والغرض من اللبرنامج هو تحديث البيانات لشهر كامل ل100 موظف ، الكود البرمجي لايعمل على المثال المرفق من قبلي لانه يحتوي على بيانات  اكثر من ال 20 اسم . شكرا لك على المساعدة .

 

الكود بعمل على  اكثر من ذلك بكثير (مهما كان عدد الاسماء حنى و لو 2000000 اسم) انا ارسلت لك نموذج فقط

و لا اعرف ما السبب عندك ربما كانت الاسماء مختلقة او التاريخ محتلف يين شيت و اخر

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

شكرا اخي سليم لاكني اعتقد ان هناك خلل بسيط في الكود ، فعند تغير التاريخ في صفحة ال Main ( مثلا 1/15/2017 ) والتاريخ هذا ليس موجودا في قاعدتي البيانات سوف تظهر نفس النتائج علما ان التاريخ هذا ليس موجودا وشروط جلب ال4 اوقات هو تطابق اسم المستخدم وتاريخ اليوم المراد البحث عنه .

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

السلام عليكم ورحمة الله

اخى العزيز ضع هذين الكودين معا فى موديول واحد

واربط الكود الاول بزر التحكم  عسى الله ان يكون هذا هو المطلوب

ملحوظة صغيرة : الكود قد يستغرق بعض الوقت للتنفيذ

Sub Calling_Data()
LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
LS = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For R = 2 To LR
For S = 2 To LS
If Cells(R, "A") = Sheet2.Cells(S, "B") Then
If Cells(R, "B") = Sheet2.Cells(S, "A") Then
   Cells(R, "E") = Sheet2.Cells(S, "C")
    Cells(R, "F") = Sheet2.Cells(S, "D")
    End If
     End If
    Next
    Next
Application.ScreenUpdating = True
Call Calling2_Data
End Sub
Sub Calling2_Data()
LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
LS = Sheet3.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For R = 2 To LR
For S = 2 To LS
If Cells(R, "A") = Sheet3.Cells(S, "B") Then
If Cells(R, "B") = Sheet3.Cells(S, "A") Then
   Cells(R, "C") = Sheet3.Cells(S, "D")
    Cells(R, "D") = Sheet3.Cells(S, "E")
    End If
     End If
    Next
    Next
    MsgBox "Êã ÇáÊÑÍíá ÈäÌÇÍ "
Application.ScreenUpdating = True
End Sub

 

تم تعديل بواسطه زيزو العجوز
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information