kodu aşağıdakiyle değiştirip dener misiniz?

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ı],1,0)) AS Geç, " & _

         "Sum(IIf(len([Data$].[Açıklama] & '' )>0,1,0)) AS Muaf, " & _

         "Sum(1) AS Toplam, " & _

         "Sum(IIf([Data$].[HedefTeslimSaati]>=[Data$].[OrtalamaTeslimAlmaZamanı],1,0))/Sum(1) 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 & "\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_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

yapılan değişiklikler
1 - Muaf alanı için hesaplama satırı eklendi

"Sum(IIf(len([Data$].[Açıklama] & '' )>0,1,0)) AS Muaf, "

2 - I sütunu eklendiğinden silme ve hücre biçimlendirme işlemlerindeki sütunlar ıdan itibaren 1 tane kaydırıldı