محتاجة تعديل لهذا الكود

yara ahmed · نوفمبر 21, 2020

السلام عليكم

هذا الكود من ابداع الاستاذ سليم حاصبيا حفظه الله وارضاه

احتاج تعديل فى

فى هذا الجزء من الكود

  Select Case D.Cells(12, "J")
          Case "Positive"
            Select Case D.Range("N1")
             Case 3: Sum_pos = 0.1475 * Sum_pos
             Case 10: Sum_pos = 0.705 * Sum_pos

اللون الاحمر والازرق =

   Case "R_B"
      For Each Sh In Sheets
       If Sh.Tab.ColorIndex = 55 _
        Or Sh.Tab.ColorIndex = 10 Then
        ReDim Preserve Arr_sh(m)
        Arr_sh(m) = Sh.Name: m = m + 1
       End If

عايزة اختار"R_B"

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

يعنى اختار فى N1

"R_B"=يتنفذ

       Case 5: Sum_pos = sum_pos- 15%* Sum_pos-Sum_pos*10%-sum_pos*4.5%+sum_neg
             Case 10: Sum_pos = sum_pos- 15%* Sum_pos-Sum_pos*10%-sum_pos*25.25%+sum_neg

لان الان الكود عند استدعاءR_B

بينفذ على الشيتات الحمراء والزرقاء مع بعض مثلا

          Case "Positive"
            Select Case D.Range("N1")
               Case "R_B": Sum_pos = sum_pos- 15%* Sum_pos-Sum_pos*10%-sum_pos*4.5%+sum_neg

التعديل المطلوب باختصار واسفة للاطالة

عايز الكود عند اختيار"R_B" فى N1

ينفذ معادلتين معادلة للشيت الاحمر

وهى

  Case 5: Sum_pos = sum_pos- 15%* Sum_pos-Sum_pos*10%-sum_pos*4.5%+sum_neg

ومعادلة للشيت الازرق وهى

  Case 5: Sum_pos = sum_pos- 15%* Sum_pos-Sum_pos*10%-sum_pos*25.25%+sum_neg

ويستدعيهم مع بعض فى نفس الوقت

مع الشكر الجزيل وخالص الدعاء

Yara_More_Optione.xlsb

تم تعديل نوفمبر 21, 2020 بواسطه yara ahmed

**سليم حاصبيا** · نوفمبر 21, 2020

صممت لك كود لأخضر والأحمر R_G

(على اساس انه اخر سؤال) من أين اتى R_B ؟؟؟ ( لماذا اختلفت المعادلات عما ورد في الرسالة على الحاص؟؟)

الكود للـــ R_G يمكنك تعديل المعادلات داخله كما نريدين (و سوف أغلق الموضوع لأنه اخذ اكثر يكثير من وقته)

Option Explicit
Sub get_By_Color()
Dim D As Worksheet
Dim Sh As Worksheet
Dim Ar(), Min_date As Date, Max_date As Date
Dim K%, t%, Arr_sh()
Dim My_ro%, m%, ro%, my_sum#, x%
Dim Sum_pos#, Sum_Neg#
Dim Part_sum#
K = 2
Set D = Sheets("DataReport")
D.Rows.Hidden = False
If D.Range("A3").CurrentRegion.Rows.Count > 1 Then
  D.Range("A3").CurrentRegion.Offset(1). _
  Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear
End If
If Not IsDate(D.Range("J2")) Or _
 Not IsDate(D.Range("K2")) Then Exit Sub
 Min_date = Application.Min(D.Range("J2:K2"))
 Max_date = Application.Max(D.Range("J2:K2"))
  Ar = Array("E", "F", "G", "H", "I", "J")
'For Each Sh In Sheets
  Select Case UCase(D.Range("N1"))
     Case 3, 10, 55
      For Each Sh In Sheets
       If Sh.Tab.ColorIndex = D.Range("N1") Then
       ReDim Preserve Arr_sh(m)
       Arr_sh(m) = Sh.Name: m = m + 1
       End If
      Next
    Case "R_B"
      For Each Sh In Sheets
       If Sh.Tab.ColorIndex = 3 _
        Or Sh.Tab.ColorIndex = 55 Then
        ReDim Preserve Arr_sh(m)
        Arr_sh(m) = Sh.Name: m = m + 1
       End If
      Next
    Case "R_G"
      For Each Sh In Sheets
       If Sh.Tab.ColorIndex = 3 _
        Or Sh.Tab.ColorIndex = 10 Then
        ReDim Preserve Arr_sh(m)
        Arr_sh(m) = Sh.Name: m = m + 1
       End If
       Next
     Case "G_B"
     For Each Sh In Sheets
        If Sh.Tab.ColorIndex = 10 _
         Or Sh.Tab.ColorIndex = 55 Then
         ReDim Preserve Arr_sh(m)
         Arr_sh(m) = Sh.Name: m = m + 1
        End If
        Next
      Case Else
      For Each Sh In Sheets
        If Sh.Tab.ColorIndex = 3 _
         Or Sh.Tab.ColorIndex = 10 _
         Or Sh.Tab.ColorIndex = 55 Then
         ReDim Preserve Arr_sh(m)
         Arr_sh(m) = Sh.Name: m = m + 1
        End If
       Next
   End Select

 If m = 0 Then Exit Sub
For m = LBound(Arr_sh) To UBound(Arr_sh)
 D.Cells(K, 1) = Arr_sh(m)
 D.Cells(K + 1, 1) = "Total " & D.Cells(12, "J")
 D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20
 K = K + 2
Next m

My_ro = 3
For m = LBound(Arr_sh) To UBound(Arr_sh)
  Set Sh = Sheets(Arr_sh(m))

   Sh.Range("A5:J20000").Interior.ColorIndex = xlNone
     ro = Sh.Cells(Rows.Count, 1).End(3).Row
   For K = LBound(Ar) To UBound(Ar)
        t = K + 2
        For x = 5 To ro
        
            If Sh.Cells(x, 1) <= Max_date _
            And Sh.Cells(x, 1) >= Min_date Then
             Sh.Cells(x, 1).Interior.ColorIndex = 40
              If Val(Sh.Cells(x, Ar(K))) <> 0 Then
                my_sum = my_sum + Sh.Cells(x, Ar(K))
                '+++++++++++++++++++++++++++++
         If Val(Sh.Cells(x, Ar(K))) <= 0 Then
              Sum_Neg = Sum_Neg + Val(Sh.Cells(x, Ar(K)))
              Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6
          Else
            Sum_pos = Sum_pos + Val(Sh.Cells(x, Ar(K)))
            Sh.Cells(x, Ar(K)).Interior.ColorIndex = 35
         End If
                '++++++++++++++++++++++++++
        Part_sum = Round((Sum_pos * 0.85) + Sum_Neg, 2)

              End If '<>0
            End If
        Next x
        '//////////////////////////////
  Select Case D.Cells(12, "J")
       Case "Positive"
            
            Select Case D.Range("N1")
                  Case 3: Sum_pos = 0.1475 * Sum_pos
                  Case 55: Sum_pos = 0.705 * Sum_pos
                  '}}}}}}}}}}}}}}}}}}}}}
                  Case "R_G"
                      If Sh.Tab.ColorIndex = 3 Then
                        Sum_pos = 0.1475 * Sum_pos
                      ElseIf Sh.Tab.ColorIndex = 10 Then
                        Sum_pos = 0.705 * Sum_pos
                      Else
                        Sum_pos = Sum_pos
                      End If
                  '}}}}}}}}}}}}}}}}}}}}}
                 Case Else: Sum_pos = Sum_pos
            End Select
          
          D.Cells(My_ro, t) = Sum_pos
      Case "Nagative"
          D.Cells(My_ro, t) = Sum_Neg
      Case "Part"
          D.Cells(My_ro, t) = Part_sum
      Case Else
          D.Cells(My_ro, t) = my_sum
   End Select
    '//////////////////////////////
        my_sum = 0: Sum_pos = 0: Sum_Neg = 0: Part_sum = 0
   Next K
   My_ro = My_ro + 2
Next m
D.Cells(My_ro, 1) = "Sum Of All"
Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar
    With D.Cells(My_ro - 1, 2).Resize(, 6)
      .Value = D.Cells(1, 2).Resize(, 6).Value
      .Interior.Color = vbBlue
      .Font.Color = vbWhite
    End With
D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _
"=Sum(B3:B" & My_ro - 2 & ")"
D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6

If D.Range("A3").CurrentRegion.Rows.Count > 1 Then
   With D.Range("A3").CurrentRegion.Offset(1). _
     Resize(D.Range("A3").CurrentRegion.Rows.Count - 1)
    .Borders.LineStyle = 1: .Font.Size = 14
    .Font.Bold = True: .HorizontalAlignment = xlCenter
    .Value = .Value
   End With
End If
 For m = My_ro - 2 To 3 Step -1
 
  If D.Cells(m, 1) Like "Total*" And _
  Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then

  D.Range(Cells(m, 1), Cells(m - 1, 1)).EntireRow.Hidden = True
  End If
 Next
End Sub

الصورة تظهر مكان التعدبل

والملف مرفق (تم ازالة الزركشات بالألوان لتحجيم الملف الى 2.5 ميغا و مازال كبيراً )

Yara_super_More_Optione.xlsm

yara ahmed · نوفمبر 21, 2020

جميل تمام التمام تسلم ايدك انقذتنى

ربنا ينجيك دائماااااااااااااااااااااااااااا

ربنا يحفظك ويفرحك ويسترك ويكرمك

الف الف شكر

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

انا مش عارفة اشكرك ازى والله

ربنا يعزك

ما اتحرمش منك ابداااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااا يارب اللهم امين

تسجيل الدخول

محتاجة تعديل لهذا الكود

الردود الموصى بها

yara ahmed

رابط هذا التعليق

شارك

سليم حاصبيا

رابط هذا التعليق

شارك

yara ahmed

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information