كود الوارد و الصرف للمستودع

[husain alhammadi]

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

اخواني ارجوا مساعدتي في استبدال المعادلة بالكود خاص بالوارد و الصرف للمستودع بشرط تاريخين و يتغير اتوماتيكيا  عند تغيير التواريخ في ورقة 4 

 عمود الوارد G في شيت 4 بشرط التاريخ البداية F7 و النهاية I7  و عمود الصرف H في شيت 4 بشرط التاريخ البداية F7 و النهاية I7

 عند كل تغيير في ورقة 4 

وكذلك نفس الكود 

عمود الوارد H في شيت 10 بشرط التاريخ البداية E5و النهاية G5و عمود الصرفJ في شيت 10 بشرط التاريخ البداية E5و النهاية G5

 

شاشة الدخول مع صلاحيات 5.xlsb

تم تعديل أكتوبر 27, 2023 بواسطه husain alhammadi

[محمد هشام.]

تفضل سيتم تنفيد الكود الخاص بكل ورقة عمل عند التغيير في  احدى خلايا تاريخ البداية او النهاية  سواءا في ورقة 4 او 10 

في module جديد انسخ الاكواد التالية 

Sub test1()
'********************************* تقرير الاصناف
Dim Sh As Worksheet: Set Sh = Sheet4
Dim Sh1 As Worksheet: Set Sh1 = Sheet6
Dim Sh2 As Worksheet: Set Sh2 = Sheet8
  b = Sh1.Name: C = Sh2.Name
  
  With Application
    .ScreenUpdating = False
    .Calculation = xlManual
    End With

Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000")
Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000")
Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000")

With Range("G9:G" & Range("C" & Rows.Count).End(3).Row)
    .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$F$7,'" & b & "'!" & V2.Address & ",""<=""&$I$7,'" & b & "'!" & V3.Address & ",C9)"
    .Value = .Value

With Range("H9:H" & Range("C" & Rows.Count).End(3).Row)
    .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$F$7,'" & C & "'!" & V5.Address & ",""<=""&$I$7,'" & C & "'!" & V6.Address & ",C9)"
    
    .Value = .Value
     
        End With
       End With
       
      With Application
    .ScreenUpdating = True
    .Calculation = xlAutomatic
    End With
      
End Sub
      
      
Sub test2() '************************ 'الجرد الشهري
Dim MyRng As Range
Dim Sh As Worksheet: Set Sh = Sheet10
Dim Sh1 As Worksheet: Set Sh1 = Sheet6
Dim Sh2 As Worksheet: Set Sh2 = Sheet8
  b = Sh1.Name: C = Sh2.Name
  Set MyRng = Sh.Range("A9:M44")
         
  
  
  With Application
    .ScreenUpdating = False
    .Calculation = xlManual
    End With
    
Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000")
Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000")
Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000")

With Range("H9:H44")
    .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)"
    .Value = .Value

With Range("J9:J44")
    .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$E$5,'" & C & "'!" & V5.Address & ",""<=""&$G$5,'" & C & "'!" & V6.Address & ",C9)"
    .Value = .Value
     
        End With
       End With
       
        MyRng.Replace 0, "", xlWhole
        
      With Application
    .ScreenUpdating = True
    .Calculation = xlAutomatic
    End With
      
End Sub

في حدث ورقة 4

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long
Application.ScreenUpdating = False
Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11
Lr = V1.Range("C" & Rows.Count).End(xlUp).Row

    V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value
    
    V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value
    
    V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value
    
If Intersect(Target, Range("F7:i7")) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Call test1
Application.EnableEvents = True
 On Error GoTo 0

Application.ScreenUpdating = True
End Sub

في حدث ورقة 10

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Intersect(Target, Range("E5:G5")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call test2
Application.EnableEvents = True
    On Error GoTo 0
End Sub

 

تم تعديل أكتوبر 27, 2023 بواسطه محمد هشام.

[husain alhammadi]

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

[husain alhammadi]

جَزَاكَ اللَّهُ خَيْرًا

الشيت 10 ممتاز و لكن شيت 4 لا يستجيب للامر

برنامج المستودع.xlsb

[محمد هشام.]

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

 

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

With Range("H9:H44")
    .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)"
    .Value = .Value

الى اخر صف عليه بيانات في عمود الصنف 

With Range("H9:H" & lastrow)
    .Formula = "=SUMIFS('" & b & "'!" & v1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)"
     .Value = .Value

تفضل اخي 

 

 

 

برنامج المستودع 2.xlsb

تم تعديل أكتوبر 29, 2023 بواسطه محمد هشام.

[husain alhammadi]

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

زادك الله علما وفهما و حفظك الله ورعاك وجعل الجنة مأواك