merhabalar,

ekli dosyada yapılmasını istediğim data1 doyasında I sütunun karşısına denk gelen hücrede açıklama varsa (dolu ise) o tairhte eğer ortalama teslim zamanı, hedef teslim saatinden büyükse kargo saat kontrol dosyasında o tarihi farklı renklendirerek muaf sütununa yazması.  ( örnk: gri/sizin belirleyeceğiniz uygun renk olabilir) ortalama teslim alma zamanı, hedef teslim zamanından küçükse/eşitse yine yeşil olarak renklendirip zamanında olarak hesaplamalı. 

örnek dosya ektedir. desteklerinizi talep ederim.

Saygılarımla...

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

Hocam, 

Bazı hücreleri renklendirdi. Ama neden eksik oldu, açıklama olan başka hücreler yine kırmızı geldi sizin kodunuz ile değiştirdiğim dosyanın son halini ekliyorum. görselde seçilen tarihlerde de hata verdi. hata görselini data dosyasına ekledim.

For x = LBound(dzR) To UBound(dzR) bu satırı
For x = LBound(dzR,2) To UBound(dzR,2) ile değiştirip dener misiniz
Not: 3. mesajdaki kodu yeniden düzenledim

Sub xRenkli()

Application.ScreenUpdating = False

Dim HdfSyf As String: HdfSyf = "Saat Bazlı Uyum"

Dim RngDz As Variant

'______________________________________________________

SQLRnk = "SELECT (" & _

                  "trim([Data$].Kargo) & '|' & " & _

                  "trim([Data$].Rota) & '|' & " & _

                  "trim([Data$].Sehir) & '|' & " & _

                  "trim([Data$].AlacakDepo) & '|' & " & _

                  "trim([Data$].MagazaAdi) & '|' & " & _

                  "Format([HedefTeslimSaati],'HH:mm')) as xKey,format([TeslimTarih],""dd.mm.yyyy"") " & _

         "FROM [Data$] " & _

         "WHERE len([Data$].[Açıklama] & '' )>0"

Set ADO_CN = CreateObject("Adodb.Connection")



yol = ThisWorkbook.Path & "\Data1.xlsx"



ADO_CN.connectionstring = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & yol & _

                          ";extended properties=""excel 12.0;hdr=yes"""

ADO_CN.Open



Set ADO_RSRnk = ADO_CN.Execute(SQLRnk)



dzR = ADO_RSRnk.getrows

'______________________________________________________

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)

'Debug.Print .Range(Cells(2, 6), Cells(SonStr, SonStn)).Address

    .UsedRange.Offset(1, 13).Interior.Color = xlNone '

    .Range(.Cells(2, 14), .Cells(sonStr, SonStn)).Interior.Color = 14994616

    For x = 1 To dzUstStr

    If Len(RngDz(x, 1) & "") = 0 Then GoTo xDgrStr

        For y = 9 To dzUstStn 'y tarihlerin başladığı sütun dizi F den başladığı ve tarihte N den başladığı için diziye göre 9. sütun

            If Len(RngDz(x, y) & "") = 0 Then GoTo xDgrStn

            If RngDz(x, 1) < RngDz(x, y) Then .Cells(x + 1, y + 5).Interior.Color = 255 Else .Cells(x + 1, y + 5).Interior.Color = 5296274

xDgrStn:

        Next y

xDgrStr:

    Next x

Dim DzMuaf As Variant

ReDim DzMuaf(2 To sonStr)

For xStr = 2 To sonStr

    For stn = 1 To 6

     DzMuaf(xStr) = DzMuaf(xStr) & "|" & Trim(.Cells(xStr, stn).Text)

    Next stn

    DzMuaf(xStr) = Mid(DzMuaf(xStr), 2)

Next xStr

Set RngTrh = .Range(.Cells(1, 14), .Cells(1, SonStn))



For x = LBound(dzR, 2) To UBound(dzR, 2)

             UsrInd = Application.Match(dzR(0, x), DzMuaf, 0)

             UsrTrh = Application.Match(dzR(1, x), RngTrh, 0)

        If Not IsError(UsrInd) And UsrTrh > 0 Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow

Next x



End With

Application.ScreenUpdating = True

End Sub

Birkaç eksik var hocam,

data1 yeni veri/açıklama yapılınca hata veriyor.
seçilen tarihlerde açıklamanın tamamı boş ise hata veriyor. ( 09.10-11.10.2022 tarihlerinde yine hata verdi)
açıklama var ama teslim alma zamanı, hedef teslim saatinden küçük/eşitse onları da sarı olarak renklendiriyor. küçük/eşit ise mümkünse yeşil olmalı