استكمال تطوير ملف الاسعار من اكثر من شيت

[gamalin]

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

استكمالا للمساهمة الرائعة من اخي استاذ محمد هشام 

ارجوا 

1)  اظافة قائمة منسدلة على عمود كود الصنف لجلب الاصناف من ورقة items وحدف المعادلة الموجودة في عمود اسم الصنف وتعويضها بالاكواد .بحيث عن اي تغيير او اظافة في عمود الكود يتم جلب الاسم تلقايئا مع المبلغ  وترقيم عمود م  وحساب القيمة في حالة وجود الكمية دون الحاجة الى الظغط  على ازرار 

2) كما هو مبين بقوائم الاسعار ان هناك عدة حالات  للبيع لكل حاله سعرها الخاص مثال 

      بيع قطعي بدون نسب خصم       السعر في العمود  i

      بيع اجل بخصم 5%                  السعر في عمود    j    

      بيع نقدي بخصم 7%                السعر في عمود    L

      بيع ض بخصم 5%                   السعر في عمود     N

      بيع ض نقدي بخصم 7%           السعر في عمود     P

     بيع K.A                                 السعر في عمود      R

والمطلوب تغير عمود السعر بتغير نظام البيع في خانة E4

price list officena V2.xlsm

[محمد هشام.]

 

تفضل اخي ضع هدا في موديول 

Sub GetPrice2()       

    Dim WSPrice As Worksheet, dest As Worksheet, ws As Worksheet, WSitems As Worksheet
    Dim LASTROW&, Dest_Last&, Cpt&, DataRow&, destRow&, I&, derlig&, Z&
    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, Title As Range
    Dim XPric As Range, XROW As Range, S As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        
Set dest = Worksheets("itemout")
Set WSitems = ThisWorkbook.Sheets("items")

Set XPric = dest.[E4]: Set Title = dest.[B8:B32]: Price_list = dest.[B4].Value
If Price_list = "" Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub
If XPric = "" Then: MsgBox "يجب عليك إدخال نوع التعامل", vbInformation: Exit Sub
    If Len(Price_list) > 0 Then
      If IsDate(dest.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
    Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy"))
    With WSPrice
    If WSPrice.FilterMode Then WSPrice.ShowAllData
        DataRow = 5
        LASTROW = .Range("D" & .Rows.Count).End(xlUp).Row
        Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(LASTROW, "J"))
        Col = srcRng.Value2
    End With
For Z = 8 To 32
    Union(dest.Range("A" & Z), dest.Range("C" & Z), dest.Range("G" & Z), dest.Range("H" & Z)).ClearContents
Next Z
    With dest
        destRow = 8
        Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row
        Set KeyRng = .Range(.Cells(destRow, "B"), .Cells(Dest_Last, "F"))
        f = KeyRng.Value2: Set Dest_Rng = .Cells(destRow, "G")
       
        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)
Set XROW = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, LookAt:=xlWhole)

If Not XROW Is Nothing Then
  For Frow = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row
   Set B = WSitems.Cells.Find(What:=dest.Range("B" & Frow), LookAt:=xlPart)
   
If Not B Is Nothing And B <> "" Then dest.Range("C" & Frow) = B.Offset(0, 1).Value
Next Frow
        Réf(I, 1) = WSPrice.Cells(Cpt + 4, XROW.Column)
          Else
      MsgBox "نوع التعامل غير موجود"
    Exit Sub
  End If
End If
On Error Resume Next
    Next I
    Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf
         End If
      End If
    End If
For Each S In Title
        If S.Value <> "" Then
        J = J + 1
        S.Offset(0, -1).Value = Format(J, "0")
      End If
      Next
derlig = dest.Range("B" & dest.Rows.Count).End(xlUp).Row
With dest.Range("H8:H" & derlig)
    .Formula = "=IF(F8<>"""",F8*G8,"""")"
    .Value = .Value
       End With
   .EnableEvents = True
   .ScreenUpdating = True
dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name
End With
End Sub

وهدا في حدث ورقة itemout

 

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Target.Worksheet.Range("E4")) Is Nothing Then
    If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub
    Application.EnableEvents = False
    Call GetPrice2
    End If
    If Intersect(Target, Range("B8:B32,F8:F32,H8:H32")) Is Nothing Then Exit Sub
Call GetPrice2
Application.EnableEvents = True
On Error GoTo 0
End Sub

price list officena V3.xlsm

تم تعديل يناير 22 بواسطه محمد هشام.

[gamalin]

استاذ محمد هشام

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

كفيت ووفيت يا اخي صعنت ما طلبته وطورت الملف ايضا بشكل افضل مما وددت فلله الحمد ولك الثناء والشكر وافر التحية والاحترام اخي الكريم

[محمد هشام.]

العفو اخي يسعدنا اننا استطنا مساعدتك 

ملاحظة في حالة نسخ الكود فقط الى ملفك الاصلي يجب اولا مطابقة بيانات القائمة المنسدلة E4 مع رؤؤس الاعمدة على جميع الاوراق كما في الملف المرفق ليشتغل مع الكود بشكل جيد 

 

تم تعديل يناير 22 بواسطه محمد هشام.

[gamalin]

استاذ محمد
بعدما تنبهت للنقطة التي اشرت اليها وقمت بالتعديل وفقا لها لم يعمل الكود ايضا حتى دخلت الي كود حدث change في شيت itemout وعملت له تنفيذ اشتغل الكود 
وايضا كان حدث له توقف في الملف المرسل منك ولم اكن افهم السبب وايضا عندما عملت تنفيذ لكود الحدث عمل بكفاءة 
ترى ما المشكلة وهل سيتوجب على كثيرا تفعيل كود الحدث ؟  ام انه من الفترض ان يعمل تلقائيا مع كل تغيير يحدث في شيت itemout

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

وافر التحية والاحترام

[محمد هشام.]

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

Sub GetPrice3()
Dim WSitems As Worksheet, WSPrice As Worksheet, dest As Worksheet, ws As Worksheet
Dim s As Range, Title As Range, r As Range, Rng As Range, ShtDate As Date, MaxDate As Date
Dim c As Range, f As Range, a&, XPric As String, Clé As Range

Set WSitems = ThisWorkbook.Sheets("items")
Set dest = Worksheets("itemout")
'B4 'استخراج اسم قائمة الاسعار بشرط التاريخ المدخل في الخلية
 XPric = dest.Range("E4"): Set Title = dest.[B8:B32]
  If Len(dest.Range("B4").Value) = 0 Then: MsgBox "يجب عليك إدخال التاريخ", vbExclamation: Exit Sub
    If IsDate(dest.Range("B4").Value) Then
      For Each ws In Worksheets
        If IsDate(ws.Name) Then
          ShtDate = CDate(ws.Name)
          If ShtDate <= dest.Range("B4").Value And ShtDate > MaxDate Then MaxDate = ShtDate
        End If
      Next ws
      If MaxDate = 0 Then
          MsgBox "قائمة الأسعار " & dest & _
          vbCrLf & vbCrLf & "غير موجودة", _
 vbInformation, "التحقق من قوائم الأسعار"
Else
'تعريف الورقة الهدف
   Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy"))
    End If
  End If
  'التحقق من ادخال كود الصتف
  If Application.WorksheetFunction.CountA(dest.Range("B8:B32")) = 0 Then
     MsgBox "المرجوا ادخال كود الصنف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin"
Exit Sub
End If
With Application
        .EnableEvents = False
        .ScreenUpdating = False
  If WSPrice.FilterMode Then WSPrice.ShowAllData  
            
' البحث عن عمود نوع التعامل
Set Clé = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not Clé Is Nothing Then
' افراغ البيانات السابقة
For a = 8 To 32
Union(dest.Range("A" & a), dest.Range("C" & a), dest.Range("G" & a & ":H" & a)).ClearContents
  Next a
  
'********  ' جلب البيانات من القائمة*************

' بشرط كود الصنف عمود 'B'
For Each r In dest.Range("B8", dest.Cells(Rows.Count, 2).End(xlUp))
'D' البحث في قائمة الاسعار عمود
Set Rng = WSPrice.Range("D:D").Find(r.Value, , xlValues, xlWhole)
If Not Rng Is Nothing Then
'7(G)' وضع السعر في عمود
dest.Cells(r.Row, 7).Value = WSPrice.Cells(Rng.Row, Clé.Column).Value ' تحديد عود السعر بشرط الخلية 'E4
For Key = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row
'items'جلب اسم الصنف من ورقة
Set Col = WSitems.Cells.Find(What:=dest.Range("B" & Key), LookAt:=xlPart)
If Not Col Is Nothing And Col <> "" Then dest.Range("C" & Key) = Col.Offset(0, 1).Value
       Next Key
    End If
 Next
 ' تسلسل عمود 'A'
For Each s In Title
If s.Value <> "" Then J = J + 1: s.Offset(0, -1).Value = Format(J, "0")
Next
fRng = dest.Range("B" & dest.Rows.Count).End(xlUp).Row
'القيمة F*G
With dest.Range("H8:H" & fRng)
    .Formula = "=IF(F8<>"""",F8*G8,"""")"
    .Value = .Value
End With

' نسخ اسم قائمة السعر المستخدمة
   dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name
 
 Else
       MsgBox "نوع التعامل  غير موجود" & _
          vbCrLf & "", vbExclamation, XPric
End If
   .EnableEvents = True
   .ScreenUpdating = True
   End With

End Sub

وكما سبق الذكر سابقا عند نسخك للكود على ملفك الاصلي  تأكد  من تطابق بيانات الخلية E4 مع رؤؤوس الأعمدة في أوراق قوائم الأسعار 

اليك الملف للتجربة

 

price list officena V4.xlsm

تم تعديل يناير 24 بواسطه محمد هشام.
الغاء فلترة القوائم

[gamalin]

جزاك الله خيرا وزادك من علمه اشكرك وشكرا لسعة صدرك ووقتك ومجهودك