merhabalar,

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