حساب الاشطر واستخراج المجاميع

[tlayt kamal]

السلام عليكم

فضلا اريد كود يوزع القيمة في خلايا العمود D الى اللعمدة  E , F,G

1مثلا ادا كانت القيمة في D اصغر من 100 تحسب في الشطر الاول

2 من 101 حتى 200 الشكر اللول والثاني

3 من 201 وما فوق الشطر الثالث

واريد كمان ضرب نتائج الاشطر على الاثمنة في الخلايا L4,M4,N4

كما في المثال بالمرفق

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

حساب الاشطر.xlsm

[سليم حاصبيا]

جرب هذا الملف

الكود

Option Explicit

 Function how_to_pay(Myfact#, n1#, n2#, n3#) As Double
''''''''''''''''''''''''''''''''''''''''''
Dim How_Many#
Select Case Myfact
        Case Is <= 100
         How_Many = Myfact * n1 ' a
        Case Is <= 200
          How_Many = (100 * n1) + (Myfact - 100) * n2 ' a+b
        Case Is > 200
     How_Many = (100 * n1) + (100 * n2) + (Myfact - 200) * n3  'a+c+d
  End Select
 
 how_to_pay = How_Many
''''''''''''''''''''''''''''''''''''''''
 End Function

 

Fatura.xlsm

[tlayt kamal]

اشكرك استاذ سليم 

جعله الله في ميزان حسناتك

بس فيه نقطة مذا عن توزيع العدد للاشطر 

[سليم حاصبيا]

تم توزيع الاشطر (بواسطة المعادلات)

على فكرة اذا كنت تريد توزيع الاشطر اولاً فأنت لست بحاجة للماكرو   كما في الورقة salim  من هذا الملف

 

 

 

 

Fatura_new.xlsm

[tlayt kamal]

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

كانت رغبتي ان اعمل هذا بالماكرو لان الملف فيه بيانات كثيرة ولكن ان كان ذلك غير ممكن فلا يأس

تم تعديل نوفمبر 7, 2019 بواسطه tlayt kamal

[سليم حاصبيا]

الماكرو ما زال يعمل كما تريد  + توزيع الاشطر  (الصفحة الاولى )

[سليم حاصبيا]

الملف كاملاً بواسطة الكود

ما عليك الا ان تضغط الزر PRESS ME PLEAS

CODE

Sub get_val()
Dim R#, My_Sh As Worksheet
Set My_Sh = Sheets("Sheet1")
R = My_Sh.Cells(Rows.Count, 3).End(3).Row
With My_Sh.Range("E4").Resize(R - 3)
  .Resize(, 4).ClearContents
    .Formula = "=IF(D4<100,D4,100)"
  .Offset(, 1).Formula = _
     "=IF(D4<=100,"""",IF(AND(D4>100,D4<200),D4-100,100))"
  .Offset(, 2).Formula = _
     "=IF(AND(SUM(E4:F4)=200,D4>200),D4-SUM(E4:F4),"""")"
  .Offset(, 3).Formula = _
     "=SUMPRODUCT(E4:G4,$L$4:$N$4)"
  .Resize(, 4).Value = .Resize(, 4).Value
End With
End Sub

FILE INCLUDED

 

Fatura_new_VBA.xlsm

[tlayt kamal]

نعم استاذي هذا ما اريد بالظبط 

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

[سليم حاصبيا]

هذا ماكرو اخر يعتمد على المصفوفات  (يجب ان يكون اسرع بكثير خاصة اذا كانت البيانات كثيرة )

لا وجد لاي معادلة

Option Explicit
Sub get_val_BY_ARRYS()
Dim My_Sh As Worksheet
Dim ARR, S#, T#, R#, I#, k As Byte

Set My_Sh = Sheets("Sheet1")
R = My_Sh.Cells(Rows.Count, 3).End(3).Row
My_Sh.Range("E4").Resize(R - 3, 4).ClearContents
 
For I = 4 To R
    With My_Sh.Range("D" & I)
     If Not IsNumeric(.Value) Then GoTo next_i
      Select Case .Value
       Case Is < 100: ARR = Array(.Value, "", "")
       Case Is < 200: ARR = Array(100, .Value - 100, "")
       Case Is > 200: ARR = Array(100, 100, .Value - 200)
      End Select
    .Offset(, 1).Resize(, 3).Value = ARR
      For k = LBound(ARR) To UBound(ARR)
           If IsNumeric(ARR(k)) Then
                T = ARR(k) * Range("L4").Offset(, k)
           Else
                T = 0
           End If: S = S + T
        
      Next
     .Offset(, 4) = S: S = 0
    End With
next_i:
Next
End Sub

 

[tlayt kamal]

استاذي اعتدر عن تأخري في الرد لظروف قاهرة

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

[saad abed]

استاذ سليم

بارك الله فيكم

ماذا تعنى علامة الشباك فى المتغيرات 

الرقم 3 فى الحصول على اخر رقم بديل xlup

الكود ممتاز يا ريت تفدنا من علمك بشرح الكود على الاسطر 

تحياتى لشخصكم الكريم