اقسم بالله انا مصدومة حضرتك دكتور اكسيل
روعة جداااااااااااا
بس تقرير red
يحتاج نظرة عطف
لان الصفحات الحمراء تقريرها التقرير الاخير بالمجموع اما الخضراء هى مضبوطة
اما الصفحات الحمراء هذا الكود يعمل تمام
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%
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(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 = 4 To ro
If Sh.Cells(x, 1) <= Max_date _
And Sh.Cells(x, 1) >= Min_date Then
If Val(Sh.Cells(x, Ar(K))) <> 0 Then
Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6
my_sum = my_sum + Sh.Cells(x, Ar(K))
End If
End If
Next x
D.Cells(My_ro, t) = my_sum
my_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) = "Total" And Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then
D.Cells(m, 1).EntireRow.Hidden = True
End If
Next
End Sub
'++++++++++++++++++++++++++++++
Sub show_all()
Sheets("DataReport").Rows.Hidden = False
End Sub
نستبدله يا دكتور يا جميل
مع خالص شكرى