مساعدة : تحديد اخر سعر لصنف معين

[zezonew]

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

أرجو المساعدة من اساتذتنا الكرام  في تحديد اخر سعر لصنف معين 

يوجد الملف بالمرفقات 

توضيح للطلب :

1 - يوجد شيت BUY  وهو الشيت الذي يتم وضع اذون الوارد به حيث يتم وضع كل اذن في ROW واحد  مكون من 27 صنف بمشتملاته

 

2 - يوجد شيت STORE  و به الاصناف الموجودة بالمخزن 

 

3 - المطلوب هو ((  المعادلة )) التي تقوم بوضع اخر بيانات تم وضعها في شيت BUY  الي الاماكن المحددة لها في شيت STORE

حيث اني جربت الكود الذي يقوم بنفس المهمة (( قد تفضل علي بهذا الكود الاستاذ زيزو العجوز جزاه الله خيرا ))ولكنه يستغرق وقت كبير جدا جدا للقيام بالمهمة المطلوبة حيث ان البيانات حجمها كبير وبالتالي ياخذ وقت كبير في عملية البحث 

واليكم الملف المرفق

 

help1.rar

[ياسر خليل أبو البراء]

وعليكم السلام

جرب الكود التالي
 

Sub Test()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim arr     As Variant
    Dim str     As String
    Dim x       As Long
    Dim i       As Long
    Dim j       As Long

    Set ws = Sheets("BUY")
    Set sh = Sheets("STORE")
    arr = ws.Range("E2:FJ" & ws.Cells(Rows.Count, 5).End(xlUp).Row).Value

    Application.ScreenUpdating = False
        For x = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
            str = sh.Cells(x, 1).Value
            For i = UBound(arr, 1) To LBound(arr, 1) Step -1
                For j = UBound(arr, 2) - 5 To LBound(arr, 2) Step -6
                    If arr(i, j) <> "" And arr(i, j) = str Then
                        sh.Cells(x, 6).Value = arr(i, j + 1)
                        sh.Cells(x, 7).Value = arr(i, j + 2)
                        sh.Cells(x, 8).Value = arr(i, j + 3)
                        sh.Cells(x, 10).Value = arr(i, j + 4)
                        sh.Cells(x, 9).Value = arr(i, j + 5)
                        GoTo Skipper
                    End If
                Next j
            Next i
Skipper:
        Next x
    Application.ScreenUpdating = True
End Sub

 

[zezonew]

ماشاء الله عليك يا استاذنا الغالي ابو البراء 

الكود قام بالمطلوب و بسرعة

جزاك الله خيرا

[ياسر خليل أبو البراء]

وجزيت خيراً بمثل ما دعوت لي أخي الكريم 

الحمد لله الذي بنعمته تتم الصالحات

[ابوحمزه المصرى]

ايه الحلاوه دى يا استاذنا  ياابو البراء  ...... انت للعباقرة عنوان والله ........ ممكن تترجم اللاونجى ده

تم تعديل يناير 19, 2017 بواسطه ابوحمزه المصرى

[ياسر خليل أبو البراء]

أي لاونجي ..الكود واضح أهو ..

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