Renklendirme

değişikliği yaptığınız haliyle eklemelisiniz ki hata nerede onu göreyim
eklediğiniz satırın başına da Burası değişti--> ibaresini ekleyin

sabrınız için sağolun hocam,

Sub xVeriAl(TrhBas As Long, TrhBit As Long)
Application.ScreenUpdating = False
Dim KykSyf As String: KykSyf = "Data"
Dim HdfSyf As String: HdfSyf = "Saat Bazlı Uyum"
Dim Sql As String
Dim ADO_CN As Object

SQLGrp = "SELECT (" & _
                  "trim([Data$].Kargo) & '|' & " & _
                  "trim([Data$].Rota) & '|' & " & _
                  "trim([Data$].Sehir) & '|' & " & _
                  "trim([Data$].AlacakDepo) & '|' & " & _
                  "trim([Data$].MagazaAdi) & '|' & " & _
                  "Format([HedefTeslimSaati],'HH:mm')) as xKey,'','','','',''," & _
        "Sum(IIf([Data$].[HedefTeslimSaati]>=[Data$].[OrtalamaTeslimAlmaZamanı],1,0)) AS Zamanında, " & _
        "Sum(IIf([Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı],IIf(len([Data$].[Açıklama] & '' )>0,0,1),0)) AS Geç, " & _
        "Sum(IIf([Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı],IIf(len([Data$].[Açıklama] & '' )>0,1,0),0)) AS Muaf, " & _
        "Zamanında + Geç + MuAF AS Toplam, " & _
        Burası değişti--> "IIF(Zamanında=0 and Geç=0,0,Zamanında /(Zamanında + Geç)) AS Oran
        "format(Sum(IIf([Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı],[Data$].[OrtalamaTeslimAlmaZamanı]-[Data$].[HedefTeslimSaati],0))/Sum(IIf([Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı],1,0)),'hh:mm') & ' dk' AS OrtGec, " & _
        "iif(Sum(IIf([Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı],[Data$].[OrtalamaTeslimAlmaZamanı]-[Data$].[HedefTeslimSaati],0))/Sum(IIf([Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı],1,0))> 31*1/(24*60),'Hayır','Evet' ) AS Kabul " & _
        "FROM [Data$] " & _
        "WHERE ((([Data$].TeslimTarih) >= " & TrhBas & " And ([Data$].TeslimTarih) <= " & TrhBit & ")) " & _
        "GROUP BY [Data$].Kargo, [Data$].Rota, [Data$].Sehir, [Data$].AlacakDepo, [Data$].MagazaAdi, Format([HedefTeslimSaati],'HH:mm');"

SQLTek = "SELECT (trim([Data$].Kargo) & '|' & trim([Data$].Rota) & '|' & trim([Data$].Sehir) & '|' & trim([Data$].AlacakDepo) & '|' & trim([Data$].MagazaAdi) & '|' & Format([HedefTeslimSaati],'HH:mm')) as xKey," & _
        "clng([Data$].TeslimTarih), Format([OrtalamaTeslimAlmaZamanı],'HH:mm') " & _
        "FROM [Data$] " & _
        "WHERE ((([Data$].TeslimTarih) >= " & TrhBas & " And ([Data$].TeslimTarih) <= " & TrhBit & ")) "

Set ADO_CN = CreateObject("Adodb.Connection")

yol = ThisWorkbook.Path & "\Data2.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_RSGrp = ADO_CN.Execute(SQLGrp)
Set ADO_RSTek = ADO_CN.Execute(SQLTek)

With ThisWorkbook.Sheets(HdfSyf)
If .AutoFilterMode = True Then .AutoFilter.ShowAllData
.UsedRange.Offset(1).Clear
.UsedRange.Offset(, 13).Clear

    .Range("a2").CopyFromRecordset ADO_RSGrp
sonStr = .Cells(.Rows.Count, 1).End(xlUp).Row

If sonStr < 2 Then
    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
    GoTo son
End If

Dim dic As Object
Dim DzDgr As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    DzKey = .Range("A2:A" & sonStr).Value2
    ReDim DzDgr(1 To UBound(DzKey), 5)
    For Each itm In DzKey
        If Not dic.Exists(itm) Then        'Anahtar var mı?
            dic.Add itm, dic.Count        'dizi özelliğinde değer ekleme
            tmpDgr = Split(itm, "|")
            For xTD = 0 To 5
                DzDgr(dic.Count, xTD) = tmpDgr(xTD)
            Next xTD
        End If
    Next itm
DzTek = ADO_RSTek.getrows

    Dim DzTrh As Variant
    ReDim DzTrh(0 To dic.Count, TrhBas To TrhBit)
    'Get Upper and Lower Bounds
    maxX = UBound(DzTek, 2)
    minX = LBound(DzTek, 2)
    maxY = UBound(DzTek, 1)
    minY = LBound(DzTek, 1)
    For x = TrhBas To TrhBit
        DzTrh(0, x) = Format(x, "dd.mm.yyyy")
    Next x
    For x = minX To maxX
        xStr = dic(DzTek(0, x)) + 1
        xStn = DzTek(1, x)
        DzTrh(xStr, xStn) = DzTek(2, x)
    Next x

    .Range("a2").Resize(dic.Count, 6) = DzDgr
    .Range("N1").Resize(dic.Count + 1, TrhBit - TrhBas + 1) = DzTrh
    .Cells(1, 1).EntireRow.Font.Bold = True
    .Cells(1, 1).EntireRow.VerticalAlignment = xlBottom
    .Cells(1, 1).EntireRow.HorizontalAlignment = xlCenter
    .Range("A1:F1").WrapText = True
    .Range("A1:F1").VerticalAlignment = xlCenter
    .Range(.Cells(1, 7), .Cells(1, TrhBit - TrhBas + 14)).Orientation = xlUpward
    .Range("K:K").NumberFormat = "0.%"
'    .Range("K:K").NumberFormat = "hh:mm;@"

End With
son:
ADO_RSGrp.Close
ADO_CN.Close
Set ADO_RSGrp = Nothing
Set ADO_CN = Nothing
xRenkli 'xRenkli yordamı çağrılıyor
Application.ScreenUpdating = True

End Sub
Sub xRenkli()
Application.ScreenUpdating = False
Dim HdfSyf As String: HdfSyf = "Saat Bazlı Uyum"
Dim RngDz As Variant

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 xMin As Date, xMax As Date
xMin = CDate(.Range("N1"))
xMax = CDate(.Cells(1, SonStn))
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 and  [Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı] and " & _
                  "[TeslimTarih]>=" & CLng(xMin) & " and [TeslimTarih]<=" & CLng(xMax)

'    Ort.teslim alma zamanı> hedef teslim saatten
'[Data$].[HedefTeslimSaati]<[Data$].[OrtalamaTeslimAlmaZamanı]
Set ADO_CN = CreateObject("Adodb.Connection")

yol = ThisWorkbook.Path & "\Data2.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)

If ADO_RSRnk.EOF = True Then GoTo Bitir
dzR = ADO_RSRnk.getrows
'______________________________________________________
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))
Debug.Print RngTrh.Address

'Debug.Print xMin, xMax
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)
Debug.Print x, dzR(0, x), dzR(1, x), UsrInd + 1, UsrTrh + 13
Burası değişti-->If Not IsError(UsrInd) And Not IsError(UsrTrh) Then .Cells(UsrInd + 1, UsrTrh + 13).Interior Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow
Next x
'____________________________________________________________________________
Bitir:
End With
Application.ScreenUpdating = True
End Sub

doğru yere yapıştırmışsınız ama eksik yapıştırmışsınız
çift tırnak arası tek değişecekti
o satırı aşağıdaki gibi yazın

 "IIF(Zamanında+Geç=0,0,Zamanında /(Zamanında + Geç)) AS Oran, " & _

hayırlı günler hocam,

düzelttim orayı, son olarak burası kaldı ;)

Burası değişti-->If Not IsError(UsrInd) And Not IsError(UsrTrh) Then .Cells(UsrInd + 1, UsrTrh + 13).Interior Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow

kodları inceleyip anlamaya çalışmazsanız olmaz, ilerde ciddi anlamda sorun yaşarsınız
başlangıçta acemi olduğunuz için yardım edilse bile bir süre sonra "adamın amacı öğrenmek değil işini bize yaptırmak" algısı oluşur ve yardım alma ihtimaliniz azalır
18. mesajımı dikkatlice okuyup ilgili kodu incelerseniz yapabilirsiniz.
Not: bu forumda 3. sorunuz olsa da diğer forumlarda da sorduğunuz sorulara cevap vermişliğim vardır
yani çok acemi değilsiniz)