Skip to main content

AccessTr.neT


Renklendirme

Renklendirme

Çözüldü #1
merhabalar,

ekli dosyada yapılmasını istediğim data1 doyasında I sütunun karşısına denk gelen hücrede açıklama varsa (dolu ise) o tairhte eğer ortalama teslim zamanı, hedef teslim saatinden büyükse kargo saat kontrol dosyasında o tarihi farklı renklendirerek muaf sütununa yazması.  ( örnk: gri/sizin belirleyeceğiniz uygun renk olabilir) ortalama teslim alma zamanı, hedef teslim zamanından küçükse/eşitse yine yeşil olarak renklendirip zamanında olarak hesaplamalı. 

örnek dosya ektedir. desteklerinizi talep ederim.

Saygılarımla...
.zip Yeni WinRAR ZIP archive.zip (Dosya Boyutu: 433,02 KB | İndirme Sayısı: 6)
Cevapla
#2
merhabalar,

dosyadaki renk kodunu soğolsun hacalarımından destek alarak aşağıdaki gibi oluştu. açıklama kısmı dolu ise de ortalama teslim alam zamanı hedef teslim saatinden küçük/eşitse yeşil olarak renklendirme çalışıyor. fakat büyükse muafı olan günüde kırmızı olarak reklendiriyor. geç olan günde kırmızı olduğu için dosyada hangi gün geç hangi gün muaf ayırt edilemiyor. muaf olan günlerde hedef teslim saatten büyükse farklı renklendirilmesi için desteklerinize ihtiyacım var.

şimdiden teşekkürler.


Sub xRenkli()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim HdfSyf As String: HdfSyf = "Saat Bazlı Uyum"
    Dim RngDz As Variant
    dsy = "Data1.xlsx"
    syf = "Data"
    Workbooks.Open ThisWorkbook.Path & "/" & dsy
    Set dt = Workbooks(dsy).Sheets(syf)
    ThisWorkbook.Activate
    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)
        .UsedRange.Offset(1, 13).Interior.Color = xlNone '
        .Range(.Cells(2, 14), .Cells(SonStr, SonStn)).Interior.ColorIndex = 24
        For x = 1 To dzUstStr
            If Len(RngDz(x, 1) & "") = 0 Then GoTo xDgrStr
            For y = 9 To dzUstStn
                If Len(RngDz(x, y) & "") = 0 Then GoTo xDgrStn
                a = "[Data1.xlsx]Data!$A:$A=B" & x + 1 & ")*("
                b = "[Data1.xlsx]Data!$B:$B=A" & x + 1 & ")*("
                c = "SUBSTITUTE([Data1.xlsx]Data!$C:$C ,"" "","""")= C" & x + 1 & ")*("
                d = "[Data1.xlsx]Data!$D:$D=D" & x + 1 & ")*("
                e = "[Data1.xlsx]Data!$E:$E=E" & x + 1 & ")*("
                f = "[Data1.xlsx]Data!$F:$F=" & Cells(1, y + 5).Address
                Cells(1, dzUstStn + 6).Formula2 = "=IFERROR(MATCH(1,(" & a & b & c & d & e & f & "*1),0),0)"
                deg = dt.Cells(Cells(1, dzUstStn + 6).Value, 9).Value
                Cells(1, dzUstStn + 6).ClearContents
                If RngDz(x, 1) < RngDz(x, y) Then
                    If deg = Empty Then
                        .Cells(x + 1, y + 5).Interior.ColorIndex = 3
                        Else
                        .Cells(x + 1, y + 5).Interior.ColorIndex = 6
                    End If
                    Else
                    .Cells(x + 1, y + 5).Interior.ColorIndex = 43
                End If
xDgrStn:
            Next y
xDgrStr:
        Next x
    End With
    Workbooks(dsy).Close False
    Application.ScreenUpdating = True
End Sub
Cevapla
#3
Hocam, 

Bazı hücreleri renklendirdi. Ama neden eksik oldu, açıklama olan başka hücreler yine kırmızı geldi sizin kodunuz ile değiştirdiğim dosyanın son halini ekliyorum. görselde seçilen tarihlerde de hata verdi. hata görselini data dosyasına ekledim.
.zip Yeni WinRAR ZIP archive.zip (Dosya Boyutu: 666,79 KB | İndirme Sayısı: 1)
Cevapla
#4
For x = LBound(dzR) To UBound(dzR) bu satırı
For x = LBound(dzR,2) To UBound(dzR,2) ile değiştirip dener misiniz
Not: 3. mesajdaki kodu yeniden düzenledim
Cevapla
#5
Sub xRenkli()
Application.ScreenUpdating = False
Dim HdfSyf As String: HdfSyf = "Saat Bazlı Uyum"
Dim RngDz As Variant
'______________________________________________________
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"
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)

dzR = ADO_RSRnk.getrows
'______________________________________________________
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 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))

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)
If Not IsError(UsrInd) And UsrTrh > 0 Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow
Next x

End With
Application.ScreenUpdating = True
End Sub
Cevapla
#6
Birkaç eksik var hocam,

data1 yeni veri/açıklama yapılınca hata veriyor.
seçilen tarihlerde açıklamanın tamamı boş ise hata veriyor. ( 09.10-11.10.2022 tarihlerinde yine hata verdi)
açıklama var ama teslim alma zamanı, hedef teslim saatinden küçük/eşitse onları da sarı olarak renklendiriyor. küçük/eşit ise mümkünse yeşil olmalı
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task