AccessTr.neT

Sayfalar: 1 2 3 4 5

sonuç, gönderdiğiniz dosyadaki gibi mi olmalı?
çünkü açıklamanızda geç-Muaf için sarı olmalı demişsiniz dosyanızda yeşil
örnek dosyanızda geç-Muaf verisi olsun demiştim ama örnekte geç-muaf yok dolayısıyla eklediğiniz örnekte neden sarı alanlar var anlamadım

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

yukardaki kodu dener misiniz?
örneğinize göre değil açıklamanıza göre düzenledim
eğer olamamışsa bu sefer: fraklı tarihlerde her durum için 2 şer kayıt ekleyip, elle renklendirerek yükleyin dosyanızı
2 tane muaf-erken
2 tane muaf-Geç
2 tane Normal-erken
2 tane Normal-geç

merhabalar,

Hocam bende çalışmadı maalesef, excelden olabilir mi bilemedim istemiş olduğunuz şekilde hem saat uyumda hem de data da örnekleme olarak renklendirdim ( ek olarak eşit ise ekledim)

bu kodu denediğimde açıklama kısımlarının tamamı boş olsa bile hata vermedi, ( doğru, tamamı da boş ise rapor çalışıyor olmalı) bilgi için paylaşmak istedim

sizde neden olmuyor bilmiyorum ama aşağıdaki gifte göreceğiniz gibi kod çalıştığında sizin gösterdiğiniz sonucu veriyor

başka bilgisayarda denedim oldu, bende exceli silip yeniden yükleyince çalıştı bende de hocam süper oldu. iki sorum olacak kod için,

renk değiştirmek istediğimde kodda nereleri değişmem gerekecek
zamında 0 ise, oran ksımı boş gelmektedir. Mümkünse o kısmında %0 olarak ayarlama şansınız var mı vaktinizi almayacaksa veya ben nasıl yapmam gerekiyor.

desteğiniz ve emeğiniz için çok teşekkür ederim. hakkınızı helal edin...

görsel ekledim

If Not IsError(UsrInd) And Not IsError(UsrTrh) And .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = 255 Then .Cells(UsrInd + 1, UsrTrh + 13).Interior
bu kodu aşağıdaki ile değiştirip dener misiniz aradaki And .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = 255 koşulu gereksiz artık

    If Not IsError(UsrInd) And Not IsError(UsrTrh) Then .Cells(UsrInd + 1, UsrTrh + 13).Interior

Not : arka alan rengi .hücre.Interior.Color = 255 ile belirlenir 255 sayısı kırmızıyı , vbyellow sarıyı belirtir bu değerleri değiştirerek rengi ayarlayabilirsiniz

Sayfalar: 1 2 3 4 5

berduş

berduş

metegok

berduş

metegok

berduş