Skip to main content

AccessTr.neT


Renklendirme

Renklendirme

#13
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
Cevapla
#14
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ç
Cevapla
#15
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
.zip Yeni WinRAR ZIP archive (2).zip (Dosya Boyutu: 558,8 KB | İndirme Sayısı: 3)
Cevapla
#16
sizde neden olmuyor bilmiyorum ama aşağıdaki gifte göreceğiniz gibi kod çalıştığında sizin gösterdiğiniz sonucu veriyor
Cevapla
#17
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
Son Düzenleme: 18/10/2022, 13:16, Düzenleyen: metegok. (Sebep: resim ekleme/silme)
Cevapla
#18
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
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task