بحث عن سعر في اكتر من شيت

[gamalin]

الاخوة الافاضل 

نظرا لتغيرات الاسعار بمعدل سريع جدا 

في الملف المرفق اكثر من قائمة اسعار الاولى بتاريخ 10-1-2024 والثانية 13-1-2024 وهذة القوائم تولد تلقائيا وتسمى بتاريخ اليوم هكذا 

احتاج الى عمل كود او معادلة

في شيت itemout لاستدعاء السعر المناسب من قوائم الاسعارprice list officena.xlsm

اي اخر عرض يسبق تاريخ الفاتورة

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

 

 

[gamalin]

الاخوة الافاضل ارجو لو الطلب غير واضح الاستفسار لاوضح ما اريده 

[gamalin]

الاخووة الافاضل ارجوا الافادة هل الطلب غير واضح ام  صعب او غير ممكن 

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

[محمد هشام.]

17 ساعات مضت, gamalin said:

هل الطلب غير واضح ام  صعب او غير ممكن

ربما غير واضح ويلزمه بعض التركيز 🤔😁

تفضل اخي جرب واي استفسار او اظافة لا تتردد في دكرها 

Sub GetPrice()       
    Dim Lastrow&, Dest_Last&, Cpt&, DataRow&, WSDestRow&, i&
    Dim WSPrice As Worksheet, WSDest As Worksheet, WS As Worksheet
    Dim Clé As Object, dictKey As String, Price_list As String
    Dim srcRng As Range, KeyRng As Range, Dest_Rng As Range
    Dim Col As Variant, f As Variant, Réf As Variant

    Dim ShtDate As Date, MaxDate As Date
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        
Set WSDest = Worksheets("itemout"): Price_list = WSDest.[B4].Value
If Price_list = vbNullString Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub
    If Len(Price_list) > 0 Then
      If IsDate(WSDest.Range("B4").Value) Then
        For Each WS In Worksheets
          If IsDate(WS.Name) Then
            ShtDate = CDate(WS.Name)
            If ShtDate <= Price_list And ShtDate > MaxDate Then MaxDate = ShtDate
          End If
        Next WS
If MaxDate = 0 Then
    MsgBox "قائمة الأسعار " & Price_list & _
          vbCrLf & vbCrLf & "غير موجودة", _
 vbInformation, "التحقق من قوائم الأسعار"
Else
On Error Resume Next
    Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy"))
    With WSPrice
        DataRow = 5
        Lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
        Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(Lastrow, "J"))
        Col = srcRng.Value2
    End With

    With WSDest
        WSDestRow = 8
        Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row
        Set KeyRng = .Range(.Cells(WSDestRow, "B"), .Cells(Dest_Last, "F"))
        f = KeyRng.Value2: Set Dest_Rng = .Cells(WSDestRow, "G")
        WSDest.[G8:G32] = Empty
        ReDim Réf(1 To UBound(f, 1), 1 To 1)
    End With
    Set Clé = CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Col)
        dictKey = Col(i, 1)
        If Not Clé.exists(dictKey) And (dictKey) <> "" Then
            Clé(dictKey) = i
        End If
    Next i
    For i = 1 To UBound(f)
        dictKey = f(i, 1)
        If Clé.exists(dictKey) Then
            Cpt = Clé(dictKey)
            Réf(i, 1) = Col(Cpt, 7)
        End If
    Next i
    Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf
         End If
      End If
    End If
   .EnableEvents = True
   .ScreenUpdating = True
End With
 MsgBox "تم جلب الأسعار من قائمة" & " " & WSPrice.Name & " " & "بنجاج", _
 vbInformation, "التحقق من قوائم الأسعار"
End Sub

 

price list officena V2.xlsm

[gamalin]

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