Renklendirme - Baskı Önizleme +- AccessTr.neT (https://accesstr.net) +-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html) +--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html) +--- Konu Başlığı: Renklendirme (/konu-renklendirme.html) |
RE: Renklendirme - berduş - 18/10/2022 değişikliği yaptığınız haliyle eklemelisiniz ki hata nerede onu göreyim eklediğiniz satırın başına da Burası değişti--> ibaresini ekleyin RE: Renklendirme - metegok - 18/10/2022 sabrınız için sağolun hocam, 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, " & _ Burası değişti--> "IIF(Zamanında=0 and Geç=0,0,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 & "\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_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 Burası değişti-->If Not IsError(UsrInd) And Not IsError(UsrTrh) Then .Cells(UsrInd + 1, UsrTrh + 13).Interior Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow Next x '____________________________________________________________________________ Bitir: End With Application.ScreenUpdating = True End Sub RE: Renklendirme - berduş - 18/10/2022 doğru yere yapıştırmışsınız ama eksik yapıştırmışsınız çift tırnak arası tek değişecekti o satırı aşağıdaki gibi yazın
RE: Renklendirme - metegok - 19/10/2022 hayırlı günler hocam, düzelttim orayı, son olarak burası kaldı ;) Burası değişti-->If Not IsError(UsrInd) And Not IsError(UsrTrh) Then .Cells(UsrInd + 1, UsrTrh + 13).Interior Then .Cells(UsrInd + 1, UsrTrh + 13).Interior.Color = vbYellow RE: Renklendirme - berduş - 19/10/2022 kodları inceleyip anlamaya çalışmazsanız olmaz, ilerde ciddi anlamda sorun yaşarsınız başlangıçta acemi olduğunuz için yardım edilse bile bir süre sonra "adamın amacı öğrenmek değil işini bize yaptırmak" algısı oluşur ve yardım alma ihtimaliniz azalır 18. mesajımı dikkatlice okuyup ilgili kodu incelerseniz yapabilirsiniz. Not: bu forumda 3. sorunuz olsa da diğer forumlarda da sorduğunuz sorulara cevap vermişliğim vardır yani çok acemi değilsiniz) |