Renklendirme

1 2 3 4 5
18/10/2022, 14:48

berduş

(18/10/2022, 13:10)metegok yazdı: zamında 0 ise, oran ksımı boş gelmektedir. Mümkünse o kısmında %0 olarak ayarlama şansınız var mı
orada 0/0 hatası var galiba o nedenle sorunlu olabilir isterseniz oranın hesaplandığı satırı aşağıdaki kodla değiştirip deneyebilirsiniz
IIF(Zamanında=0 and Geç=0,0,Zamanında /(Zamanında + Geç)) AS Oran
yada
IIF(Zamanında+Geç=0,0,Zamanında /(Zamanında + Geç)) AS Oran

% kısmının kodunu da
    .Range("K:K").NumberFormat = "%.0"
yapabilirsiniz
18/10/2022, 15:11

metegok

(18/10/2022, 14:48)berduş yazdı: IIF(Zamanında=and Geç=0,0,Zamanında /(Zamanında Geç)) AS Oran  
 bu kodu ekleyemedim hocam kusura bakmayın ;( nereye eklmem gerekecek
18/10/2022, 15:14

berduş

veri ekleme kodunda Zamanında /(Zamanında + Geç olan satırı bulup o satırı değiştirin
18/10/2022, 16:23

metegok

o kısmı bulup aynı olduğu yere sizin verdiğiniz kodu ekledim hocam, 

compile error:

syntax error diye bir hata verdi, tamam deyince kodun başlangıcını sarıya boyadı
18/10/2022, 16:28

berduş

tüm kodu paylaşır mısınız?
18/10/2022, 16:32

metegok

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
1 2 3 4 5