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