اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


yara ahmed
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

هذا الكود تصميم اخى الفاضل الاستاذ الرائع سليم حاصبيا

كود جلب البيانات بين تاريخين للصفحات التى لون التاب لها اخضر والتى لونها احمر

اعمل عليه وممتاز وادعيله ربنا يوفقه يارب وينصره امين

عملت قائمة مكونة من 3 اختيارات سالب وموجب وشامل

الكود الان يجلب البيانات الموجب-السالب تمام

احتاج الى عندما اغير بالقائمة واختار سالب يجلب البيانات  السالبة فقط

وعند اختيار موجب يجلب البيانات الموجبة فقط

وعند اختيار شامل يعمل ما يعمله الان الموجب-السالب كعملية الجمع الفرق بين الموجب والسالب

واكون شاكرة وممنونة

yara_Col_test.xlsb

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

تم التعديل كما تريدين

الأعداد السالبة تظهر باللون الأصفر والموجبة بالأخضر(شرط تطابق التاريخ)  حلايا التاريخ المطلوب باللون الزهري

Option Explicit
Sub get_special_columns()
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#
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
    If Sh.Tab.ColorIndex = D.Range("N1") Then
      ReDim Preserve Arr_sh(m)
       Arr_sh(m) = Sh.Name: m = m + 1
     End If
Next Sh
 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
                '++++++++++++++++++++++++++
              End If
            End If
        Next x
         Select Case D.Cells(12, "J")
         Case "Positive"
          D.Cells(My_ro, t) = Sum_pos
         Case "Nagative"
          D.Cells(My_ro, t) = Sum_Neg
          Case Else
          D.Cells(My_ro, t) = my_sum
        End Select
        my_sum = 0: Sum_pos = 0: Sum_Neg = 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
'++++++++++++++++++++++++++++++
Sub show_all()
Sheets("DataReport").Rows.Hidden = False
End Sub

الملف مرفق

Yara_Pos_Neg_All.xlsb

  • Like 3
رابط هذا التعليق
شارك

  • 3 weeks later...

استبدلي في القائمة المنسدلة عبارة nagative-positive-nagative*15/100 بكلمة Part

 وأضيفي الى الكود كما في الصورة في المكان المناسب

الملف مرفق

 

Yara_pic.png

Yara_Part_Pos_Neg_All.xlsb

  • Like 3
رابط هذا التعليق
شارك

ما أفصدة موجود في هذا الملف الذي يظهر النتيجة نفسها بالنسبة للأعداد (Pos=100,Neg=-10)  النتيجة 75 كما تريدين

حيث ان  Neg    هي نفسها سالبة لذلك يجب حمعها وليس طرحها لانه في حال طرحها  تصبح -(-10)   اي + 10

 

Explain.xlsx

  • Like 1
رابط هذا التعليق
شارك

اليك مثال عما استطعت ان أجده

الأعداد الموجبة (حسب التاريخ)  75 و 25  مجموعها 100    %85 منها   85

الأعداد السالبة (حسب التاريخ)  10 - 

النتيجة     85+(-10) =  85-10 =  75   (تأكدي بنفسك من الباقي يدوياً)

Resalt.png

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

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

عايز اضيف pos*15%

هل اعمل كوبى لكل الشرح الى فات واكتب 

(Part_sum = Round(Sum_pos * 0.15 

اسفل السطر 

Part_sum = Round((Sum_pos * 0.85) + Sum_Neg, 2)

مشكور اخى الاستاذ العبقرى ماشاء الله عليك

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

  • أفضل إجابة

اليك هذه الاضافة الى الملف (عسى ان تنال الاعجاب)
 ايجاد pos_sum  و   Neg_sum و  All_sum  بين تاريخين في صفحة واحدة "Test_All"

Yara_All_In_One.xlsm

  • Like 2
رابط هذا التعليق
شارك

اخى استاذ الاساتذة الجميل سليم حاصبيا

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

احتاج الى استدعاء لونين او ثلاثة الوان 

فعملت محاولة كتبت ("N1&N2&N3") وبداخل N1  كتبت 3+10 , 3,10 وطبعا طبعا فشلت 

معلش  احتاجك اخى ربنا ما يحرمنى منك يارب

 If Sh.Tab.ColorIndex = D.Range("N1") Then

 

Yara_Exacte.xlsb

تم تعديل بواسطه yara ahmed
رابط هذا التعليق
شارك

اخويا حبيبى ربنا ما يحرمنى منك ابدااا

بص انا عندى الكود بيستدعى التاب الاحمر لو اختارنا اللون 3 فى الخلية N1

وبيستدعى التاب الاخضر اذا اختارنا 10فى الخلية N1

وبيستدعى التاب اللبنى اذا اختارنا 55  فى الخلية n1

انا عايزة تعديل اضافة

امكانية استدعائهم مع بعض كأنهم لون واحد

يعنى 3 للتاب الاحمر فقط

10 للتاب الاخضر فقط

55 للتاب للبنى فقط

والاضافة الجديدة 10,3,55 لاستدعاء التاب التى بالثلاث الوان مع بعض 

حفظك ورعاك ربى 

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

جربي هذا الكود لمعرفة أرقام كل الألوان

Option Explicit
Sub get_colore_index()
Dim i
Cells(1, 1) = "Color Index"
Cells(1, 2) = "Color"
For i = 2 To 57
 With Cells(i, 1)
  .Value = i - 1
  .Offset(, 1).Interior.ColorIndex = i - 1
  End With
 Next
End Sub

 

  • Like 2
رابط هذا التعليق
شارك

استاذى اخى الغالى استاذ سليم حاصبيا

هل لى بطلب تعديل لهذا الكود رجاء

هل بتعديل لكودك الرائع هذا معلش انا احتاج التعديل جدا والله

احتاج ان عند استدعاء الشيت التى بلون تاب ازرق يتمpos-pos*15%-pos*10%-pos*4.5%

واذاكان اللون احمر يتم pos-pos*10%-pos*15%-pos*25.25%

اذا كان اخضريتم pos*15%-pos*5%

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

يعنى اكتب رقم اللون مثلا3 الى هو اللون الاحمر

ويكون هناك زر اخر بكود اخر 

اضغط عليه يستدعى Pos-pos*15%-pos*10%-pos*25.25%

وهكذا لباقى الالوان

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

بعمل ورقة خارجية واكتب فيه معادلات

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

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

اختك

Yara_One _more_color.xlsb

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

ممكن الكود الجديد يعمل على لون التاب بدون ما اكتبه يعنى يستدعى كل الشيتات كلا حسب لونه يتم الخصم

معلش نسيت انا اسفة استثناء اللون الاخضر

يعنى استدعاء كل الالوان ماعدا الاخضر

مع حبي وشكرى

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

أضافة ماكرو جديد (نفس القديم مع زيادة ما في هذه الصورة) و زر جديد له  More Options

الملف اصبج بحجم كبير جداً (حوالي 9 ميغا لا يطاق)

ما كفاية بقى بحث  بهذا الموضوع الذي ضجرنا منه رغبة في مزاجية رب عملك (كل ساعة يلون)

سوف يتم اغلاق الموضوع مباشرة بعد الحصول على رد لهذه الاجابة

 

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 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

 

Yara_percent.png

الملف مرفق

Yara_More_Optione.xlsm

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information