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

[عبدالله ياسين]

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

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

sample.rar

تم تعديل يناير 17, 2017 بواسطه عبدالله ياسين
تم ادراج الموضوع خطاً

[عبدالله ياسين]

للرفع

[سليم حاصبيا]

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

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

 

[عبدالله ياسين]

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

[سليم حاصبيا]

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

 

تم تعديل يناير 18, 2017 بواسطه زيزو العجوز

[عبدالله ياسين]

اخي العزيز زيزو بالفعل الكود اتم المطلوب .شكرا جزيلا لكم على المساعدة