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

yara ahmed · أكتوبر 13, 2020

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

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

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

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

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

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

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

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

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

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

yara_Col_test.xlsb

**سليم حاصبيا** · أكتوبر 15, 2020

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

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

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

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

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

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

الملف مرفق

Yara_Part_Pos_Neg_All.xlsb

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

التعديل

استبدال المربع الاحمر بالأزرق مع التركيز على اشارة الــ + ( لأن Sum_ng هي سالبة)

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

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

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

Explain.xlsx

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

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

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

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

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

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

كان لازم من الأول كده (تعذيل الى هذا السطر)

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

Yara_Exacte.xlsb

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

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

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

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

(Part_sum = Round(Sum_pos * 0.15

اسفل السطر

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

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

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

اضيقي الى القائمة النتسدلة عنصر تحت اسم sum15

و عدلي على الكود كما في الصورة

الملف

Yara_15_Part_Pos_Neg_All.xlsb

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

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

Yara_All_In_One.xlsm

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

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

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

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

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

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

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

Yara_Exacte.xlsb

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

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

انا اسفة ها هو

Yara_Exacte.xlsb

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

أضيفى الى القائمة المنسدلة الرقم 55

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

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

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

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

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

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

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

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

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

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

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

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

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

تعدبل في الكود

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

تم العمل كما تريدين بعد التعديل على الكود

Yara_One _more_color.xlsb

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

هذه الصورة توضح الأمر

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

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

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

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

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

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

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

احتاج ان عند استدعاء الشيت التى بلون تاب ازرق يتم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

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

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

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

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

مع حبي وشكرى

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

أضافة ماكرو جديد (نفس القديم مع زيادة ما في هذه الصورة) و زر جديد له 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_More_Optione.xlsm

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

اخويا حبيبى الف شكر لحضرتك جدااااااااااااااااااااااااا

متزعلش منى والله زعلك على راسى

ربنا يخليك لينا يارب ويحفظك ويعزك اللهم امين

تسجيل الدخول

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

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

yara ahmed

سليم حاصبيا

سليم حاصبيا

سليم حاصبيا

سليم حاصبيا

سليم حاصبيا

سليم حاصبيا

yara ahmed

سليم حاصبيا

سليم حاصبيا

yara ahmed

yara ahmed

سليم حاصبيا

yara ahmed

سليم حاصبيا

سليم حاصبيا

سليم حاصبيا

سليم حاصبيا

yara ahmed

yara ahmed

سليم حاصبيا

yara ahmed

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

تصفح الموقع

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

Support

Important Information