dosyadaki renk kodunu soğolsun hacalarımından destek alarak aşağıdaki gibi oluştu. açıklama kısmı dolu ise de ortalama teslim alam zamanı hedef teslim saatinden küçük/eşitse yeşil olarak renklendirme çalışıyor. fakat büyükse muafı olan günüde kırmızı olarak reklendiriyor. geç olan günde kırmızı olduğu için dosyada hangi gün geç hangi gün muaf ayırt edilemiyor. muaf olan günlerde hedef teslim saatten büyükse farklı renklendirilmesi için desteklerinize ihtiyacım var.
şimdiden teşekkürler.
Sub xRenkli()
On Error Resume Next
Application.ScreenUpdating = False
Dim HdfSyf As String: HdfSyf = "Saat Bazlı Uyum"
Dim RngDz As Variant
dsy = "Data1.xlsx"
syf = "Data"
Workbooks.Open ThisWorkbook.Path & "/" & dsy
Set dt = Workbooks(dsy).Sheets(syf)
ThisWorkbook.Activate
With ThisWorkbook.Sheets(HdfSyf)
SonStr = .Cells(.Rows.Count, "J").End(xlUp).Row '3
SonStn = .Cells(1, .Columns.Count).End(xlToLeft).Column '21
RngDz = .Range(Cells(2, 6), Cells(SonStr, SonStn)).Value2
dzUstStn = UBound(RngDz, 2)
dzUstStr = UBound(RngDz, 1)
.UsedRange.Offset(1, 13).Interior.Color = xlNone '
.Range(.Cells(2, 14), .Cells(SonStr, SonStn)).Interior.ColorIndex = 24
For x = 1 To dzUstStr
If Len(RngDz(x, 1) & "") = 0 Then GoTo xDgrStr
For y = 9 To dzUstStn
If Len(RngDz(x, y) & "") = 0 Then GoTo xDgrStn
a = "[Data1.xlsx]Data!$A:$A=B" & x + 1 & ")*("
b = "[Data1.xlsx]Data!$B:$B=A" & x + 1 & ")*("
c = "SUBSTITUTE([Data1.xlsx]Data!$C:$C ,"" "","""")= C" & x + 1 & ")*("
d = "[Data1.xlsx]Data!$D:$D=D" & x + 1 & ")*("
e = "[Data1.xlsx]Data!$E:$E=E" & x + 1 & ")*("
f = "[Data1.xlsx]Data!$F:$F=" & Cells(1, y + 5).Address
Cells(1, dzUstStn + 6).Formula2 = "=IFERROR(MATCH(1,(" & a & b & c & d & e & f & "*1),0),0)"
deg = dt.Cells(Cells(1, dzUstStn + 6).Value, 9).Value
Cells(1, dzUstStn + 6).ClearContents
If RngDz(x, 1) < RngDz(x, y) Then
If deg = Empty Then
.Cells(x + 1, y + 5).Interior.ColorIndex = 3
Else
.Cells(x + 1, y + 5).Interior.ColorIndex = 6
End If
Else
.Cells(x + 1, y + 5).Interior.ColorIndex = 43
End If
xDgrStn:
Next y
xDgrStr:
Next x
End With
Workbooks(dsy).Close False
Application.ScreenUpdating = True
End Sub