mevcut kod hocam renk kodunu da eklediğimde hata verdi ben yapamadım yine ;(
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, " & _
"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 & "\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)
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
If Not IsError(UsrInd) And Not IsError(UsrTrh) And .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = 255 Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow
Next x
'____________________________________________________________________________
Bitir:
End With
Application.ScreenUpdating = True
End Sub