استخدام VLOOKUP بالVBA بدل الدالات

[ابو هاله النبلسي]

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

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

نسخة من officene.xlsm

تم تعديل يناير 7, 2023 بواسطه ابو هاله النبلسي

[محمد هشام.]

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

تفضل اخي

نسخة من officene.xlsm

[ابو هاله النبلسي]

كل التوفيق عمل راقي جدا حاب اطمع بكرم حضرتك ممكن يكون ديناميكي بامكان 40000 سجل ممكن لو تفضلت 

[ابو هاله النبلسي]

السلام عليكم ورحمة الله وبركاته بعد التحية ...

كيف يتم اعتماد VLOOKUP عن طريق VBA حسب المرفق والجدول انا عملت بالدالة لكن احتاجه بالVBA ياريت يكون الحل ديناميكي عند اضافة حقول يتم اعتمادها بعد تنفيذ الكود

نسخة من نسخة من officene (2).xlsm

[ابو هاله النبلسي]

السلام عليكم ورحمة الله وبركاته بعد التحية ...

كيف يتم اعتماد VLOOKUP عن طريق VBA حسب المرفق والجدول انا عملت بالدالة لكن احتاجه بالVBA ياريت يكون الحل ديناميكي عند اضافة حقول يتم اعتمادها بعد تنفيذ الكود

 

نسخة من نسخة من officene (2).xlsm

[محمد هشام.]

2 ساعات مضت, ابو هاله النبلسي said:

ياريت يكون الحل ديناميكي عند اضافة حقول يتم اعتمادها بعد تنفيذ الكود

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

Sub TEST_MH2()
Dim MT As Worksheet
Dim lr As Long
Set MT = Worksheets("sheet4")

Application.ScreenUpdating = False
lr = MT.Range("A" & Rows.Count).End(xlUp).Row
MT.Range("F2:i" & lr).ClearContents

  With MT.Range("F2:F" & lr)
       .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)"
       .Value = .Value
           With MT.Range("G2:G" & lr)
            .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)"
            .Value = .Value
               With MT.Range("H2:H" & lr)
               .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)"
               .Value = .Value
                   With MT.Range("I2:I" & lr)
                  .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)"
                  .Value = .Value
  End With
   End With
    End With
     End With
  Application.ScreenUpdating = True
End Sub

 

نسخة من نسخة officene _2.xlsm

[ابو هاله النبلسي]

احسنت وبارك الله فيك عاشت الايادي 

[محمد هشام.]

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

اليك كود اخر يقوم بنفس المهمة لاكن حاول تجنب وضع علامة / بين الكلمات يمكنك استبدالها ب علامة (-) مثلا وسوف يشتغل معك الكود بكفاءة عالية

بالتوفيق

Sub Test_MH3()
Dim a, b
Dim I As Long, II As Long, LR As Long
Dim j As Integer
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")
Dim K, T
    LR = Cells(Rows.Count, "A").End(3).Row
    a = Range("A2:D" & LR)
    For I = LBound(a, 1) To UBound(a, 1)
        ObjDic(a(I, 1)) = a(I, 2) & "/" & a(I, 3) & "/" & a(I, 4)
    Next I
    LR = Cells(Rows.Count, "e").End(3).Row
    b = Range("E2:E" & LR)
    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 5)
    
    For I = LBound(b, 1) To UBound(b, 1)
        For Each K In ObjDic.keys
            If K Like "*" & b(I, 1) & "*" Then
                T = Split(ObjDic(K), "/")
                 b(I, 1) = K
                For II = 0 To UBound(T, 1)
                    b(I, 2 + II) = T(II)
                Next II
                Exit For
            End If
        Next K
    Next I
    Cells(2, "F").Resize(UBound(b, 1), 4) = b

End Sub

 

نسخة من نسخة officene _3.xlsm

تم تعديل يناير 7, 2023 بواسطه Mohamed Hicham

[وليد المصرى 1]

استاذ محمد جزاك الله خير

ولكن لو ان الكود بياخد البيانات من شيت اخر وليس من نفس الشيت ماذا يكون الكود ؟

[محمد هشام.]

تفضل اخي هذا مثال لطلبك 

Sub TEST_mh5()
Dim ws As Worksheet
Dim LR As Long
Set ws = Worksheets("sheet2")
Application.ScreenUpdating = False

LR = ws.Range("B" & Rows.Count).End(xlUp).Row

 With ws.Range("c2:c" & LR)
       .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,1,0)"
       .Value = .Value

With ws.Range("d2:d" & LR)
       .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,2,0)"
       .Value = .Value

 With ws.Range("E2:E" & LR)
       .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,3,0)"
       .Value = .Value
 
 With ws.Range("F2:F" & LR)
       .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,4,0)"
       .Value = .Value
       
With ws.Range("G2:G" & LR)
       .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,5,0)"
       .Value = .Value
End With
 End With
  End With
   End With
    End With

End Sub

 

جلب البيانات 2.xlsm

تم تعديل يناير 8, 2023 بواسطه Mohamed Hicham

[YOUCEF - 41]

بارك الله فيكم يا اساتذتنا الكرام

[محمد هشام.]

وفي حالة وضع شرط لو الخلية فارغة يمكنك جعل الكود كالتالي

With ws.Range("c2:c" & LR)
        .Formula = "=IF(B2="""","""",VLOOKUP(""*""&B2&""*"",sheet1!A:E,1,0))"
       .Value = .Value

 

[وليد المصرى 1]

بارك الله فيك اخى محمد مممكن يكون الكود اتوماتيك بدون اضافة زر