اريد كود بديل لمعادلة vlookup

[yamanyy]

السلام عليكم 

         ارجو المساعدة فى توضيح كود بديل لمعادلة vlookup لاننى املك ملف يوجد به بيانات تزيد عن 200,000 واواجه مشكلة ان المعادلة تاخذ وقت كثير جدا لانى اريد النقل من ملف اسمهCreated1 عمود B الى ملف اسمه Booked عمود B ايضاً ومرفق الملفات لمساعدتى بكود بديل للمعادلة ال بتقض ساعات طويلة للانتهاء من النقل .

 

شكراً جزيلاً

 

تجربة.rar

[yamanyy]

ارجو المساعدة

[Ali Mohamed Ali]

تفضل

 

تجربة.rar

[yamanyy]

شكرا جزيلاً اخى على المجهود الرائع وتمت التجربة ونجحت . 

ولكن عند الضغط على f11 لكى اتعلم الكود فى ملف ال Booked لم اجده فهل هناك امكانية لكى اراه واتعلمه . 

 

 

 

[yamanyy]

بعتزر لحضرتك فعلا وجدت الكود وفى شرح فوق كل كود بس اللغة العربية عندى غير مفعلة لو امكن حضرتك تكتبلى الكود هنا بشرحه ولك جزيل الشكر 

[Ali Mohamed Ali]

أولا لابد من الضغط على Alt+F11 وليس F11 بمفردها

وهذا الكون من أعمال وابداعات استاذنا الكبير ياسر خليل له منا كل المحبة والإحترام

Sub ImportDataFromClosedWBUsingVLOOKUP()
'تعريفات المتغيرات
      Dim WBK As Workbook
    Dim Rng As Range
    Dim LastRow As Long
'إيقاف تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
'ايقاف خاصية رسائل التنبيه
    Application.DisplayAlerts = False
    
' والموجود فى نفس مسار المصنف الحالى Createdليساوى المصنف المسمى   [WBK] تعيين قيمة للمتغير 
'يقوم هذا السطر ايضا بفتح المصنف فى المسار المذكور
        Set WBK = Workbooks.Open(ThisWorkbook.Path & "\Created.xlsb")
'تعيين قيمة للنطاق المراد جلب البيانات منه من المصنف المسمى Created
        Set Rng = Range("A2:b" & Cells(Rows.Count, 1).End(xlUp).Row)
        
'[Sheet1]بدء التعامل مع المصنف الحالى فى ورقة العمل
        With ThisWorkbook.Sheets("Sheet1")
'تحديد رقم صف أخر خليةبها بيانات فى العمود الأول
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'وضع معادلة دالة البحث فى العمود الثانى والحصول على النتيجةمن العمود الثانى فى المصنف Created
            With .Range("B2").Resize(LastRow - 1)
                .Formula = "=IFERROR(VLOOKUP(A2," & Rng.Address(, , , True) & ",2,False),"""")"
                .Value = .Value
            End With
                      End With
'اغلاق المصنف المأخوذ منه البيانات بدون حفظ
        WBK.Close SaveChanges:=False

'إعادة تفعيل خاصية رسائل التنبيه
    Application.DisplayAlerts = True
'إعادة تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

 

[yamanyy]

الحقيقة كامل الاحترام والتقدير والشكر لحضرتك وللاستاذ ياسر جلال على ابداعه فعلاً  . 

[yamanyy]

هوفي امكانية فى توضيح طريقة  ربط الـ shape ال اسمها Run  بالكود كدة ؟ 

[Ali Mohamed Ali]

انه امر سهل للغاية كما بالصور

 

[yamanyy]

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