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...
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
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.
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
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
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ı