anish.ms
01-10-2021, 09:37 AM
May I request help in the following modification in the code
Assignments which are not due as on date has to be colored based on the color in M6 in Base sheet
27704
Expected result
27705
Sub Do_It()
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
sh1 = "Dashboard"
sh2 = "Scheduler"
sh3 = "Base"
d0 = Sheets("Base").Range("M1")
If d0 = Empty Then d0 = Date - 7
With Sheets(sh1)
d1 = d0 - Weekday(d0, vbMonday)
d2 = d1 + 90
xx = 1
For d = d1 To d2
x = 2 + d - d1
If xx = 1 Then
.Cells(4, x + 0) = Format(d - 90, "ww", vbSunday, vbFirstFourDays)
.Cells(4, x + 2) = d
.Cells(4, x + 2).NumberFormat = "mmm yyyy"
End If
xx = xx + 1
If xx > 7 Then xx = 1
.Cells(5, x) = d
.Cells(6, x) = Left(Format(d, "ddd"), 1)
Next d
.Range("B5:CN5").Interior.Color = .Range("H4").Interior.Color
a_max = .Cells(.Rows.Count, "A").End(xlUp).Row
If a_max > 6 Then
With .Range("A7:CN" & a_max)
.ClearContents
.Interior.ColorIndex = xlNone
End With
End If
x = WorksheetFunction.Match(CLng(Date), .Range("5:5"), 0)
M3 = Sheets("base").Range("M3").Interior.Color
If Err.Number = 0 Then
.Range(.Cells(7, x), .Cells(a_max, x)).Interior.Color = M3
.Cells(5, x).Interior.Color = M3
End If
Err.Clean
End With
With Sheets(sh3)
bg1 = .Range("M4").Interior.Color
bg2 = .Range("M5").Interior.Color
a = 2
Do
mena = .Cells(a, "A")
Sheets(sh1).Cells(5 + a, "A") = mena
With Sheets(sh2)
b = 2
Do
If .Cells(b, "A") = mena Then
per = FormatPercent(.Cells(b, "H"), 0)
LM = .Cells(b, "F")
pqr = Application.VLookup(LM, Sheets(sh3).Range("Managers"), 2, False)
If Not IsError(pqr) Then LM = pqr
QM = .Cells(b, "G")
pqr = Application.VLookup(QM, Sheets(sh3).Range("Quality"), 2, False)
If Not IsError(pqr) Then QM = pqr
smallStr = per & " (" & .Cells(b, "J") & "/" & .Cells(b, "I") & ") " & LM & "|" & QM
sepStr = " | "
bc = .Cells(b, "B") & " : " & .Cells(b, "C") & sepStr & smallStr
dd = .Cells(b, "D")
ee = .Cells(b, "E")
If dd > 0 And ee > 0 Then
gg = dd + (ee - dd) * .Cells(b, "H")
With Sheets(sh1)
done = False
For d = dd To ee
If d >= d1 And d <= d2 Then
bg = bg1
If d > gg Then bg = bg2
With .Cells(5 + a, 2 + d - d1)
If .Interior.ColorIndex = xlNone Or .Interior.Color = M3 Then
.Interior.Color = bg
Else
.Interior.ColorIndex = 3
End If
End With
If Not done Then
With Cells(5 + a, 2 + d - d1)
.Value = bc
.Font.Size = 10
.Font.ColorIndex = 2
.Characters(InStr(1, bc, sepStr, vbTextCompare)).Font.ColorIndex = 8
.Characters(InStr(1, bc, smallStr, vbTextCompare)).Font.ColorIndex = 36
.Characters(InStr(1, bc, smallStr, vbTextCompare)).Font.Size = 6.5
End With
done = True
End If
End If
Next d
End With
End If
End If
b = b + 1
Loop Until .Cells(b, "A") = Empty
End With
a = a + 1
Loop Until .Cells(a, "A") = Empty
End With
Sheets(sh1).Range("H1:I1").Activate
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Assignments which are not due as on date has to be colored based on the color in M6 in Base sheet
27704
Expected result
27705
Sub Do_It()
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
sh1 = "Dashboard"
sh2 = "Scheduler"
sh3 = "Base"
d0 = Sheets("Base").Range("M1")
If d0 = Empty Then d0 = Date - 7
With Sheets(sh1)
d1 = d0 - Weekday(d0, vbMonday)
d2 = d1 + 90
xx = 1
For d = d1 To d2
x = 2 + d - d1
If xx = 1 Then
.Cells(4, x + 0) = Format(d - 90, "ww", vbSunday, vbFirstFourDays)
.Cells(4, x + 2) = d
.Cells(4, x + 2).NumberFormat = "mmm yyyy"
End If
xx = xx + 1
If xx > 7 Then xx = 1
.Cells(5, x) = d
.Cells(6, x) = Left(Format(d, "ddd"), 1)
Next d
.Range("B5:CN5").Interior.Color = .Range("H4").Interior.Color
a_max = .Cells(.Rows.Count, "A").End(xlUp).Row
If a_max > 6 Then
With .Range("A7:CN" & a_max)
.ClearContents
.Interior.ColorIndex = xlNone
End With
End If
x = WorksheetFunction.Match(CLng(Date), .Range("5:5"), 0)
M3 = Sheets("base").Range("M3").Interior.Color
If Err.Number = 0 Then
.Range(.Cells(7, x), .Cells(a_max, x)).Interior.Color = M3
.Cells(5, x).Interior.Color = M3
End If
Err.Clean
End With
With Sheets(sh3)
bg1 = .Range("M4").Interior.Color
bg2 = .Range("M5").Interior.Color
a = 2
Do
mena = .Cells(a, "A")
Sheets(sh1).Cells(5 + a, "A") = mena
With Sheets(sh2)
b = 2
Do
If .Cells(b, "A") = mena Then
per = FormatPercent(.Cells(b, "H"), 0)
LM = .Cells(b, "F")
pqr = Application.VLookup(LM, Sheets(sh3).Range("Managers"), 2, False)
If Not IsError(pqr) Then LM = pqr
QM = .Cells(b, "G")
pqr = Application.VLookup(QM, Sheets(sh3).Range("Quality"), 2, False)
If Not IsError(pqr) Then QM = pqr
smallStr = per & " (" & .Cells(b, "J") & "/" & .Cells(b, "I") & ") " & LM & "|" & QM
sepStr = " | "
bc = .Cells(b, "B") & " : " & .Cells(b, "C") & sepStr & smallStr
dd = .Cells(b, "D")
ee = .Cells(b, "E")
If dd > 0 And ee > 0 Then
gg = dd + (ee - dd) * .Cells(b, "H")
With Sheets(sh1)
done = False
For d = dd To ee
If d >= d1 And d <= d2 Then
bg = bg1
If d > gg Then bg = bg2
With .Cells(5 + a, 2 + d - d1)
If .Interior.ColorIndex = xlNone Or .Interior.Color = M3 Then
.Interior.Color = bg
Else
.Interior.ColorIndex = 3
End If
End With
If Not done Then
With Cells(5 + a, 2 + d - d1)
.Value = bc
.Font.Size = 10
.Font.ColorIndex = 2
.Characters(InStr(1, bc, sepStr, vbTextCompare)).Font.ColorIndex = 8
.Characters(InStr(1, bc, smallStr, vbTextCompare)).Font.ColorIndex = 36
.Characters(InStr(1, bc, smallStr, vbTextCompare)).Font.Size = 6.5
End With
done = True
End If
End If
Next d
End With
End If
End If
b = b + 1
Loop Until .Cells(b, "A") = Empty
End With
a = a + 1
Loop Until .Cells(a, "A") = Empty
End With
Sheets(sh1).Range("H1:I1").Activate
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub