• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Listview'de gun farklarini renklendirme

  • Konbuyu başlatan Konbuyu başlatan lapot
  • Başlangıç tarihi Başlangıç tarihi
L

lapot

Katılım
4 Temmuz 2006
Mesajlar
239
Arkadaslar saygilar
Listviwide faturalar lista halinde tarihleriyle beraber sirali ve onlari renklendirmek istiyorum.
Asagidakini cumleyi asagidaki koda nasil uygulayabilirim?

Tarih, Bugun ‘e esit ise ------ Kirmizi
Tarih, Bugun’e esit degil ve 30 gunden kucuk ise ----- mavi ve ayrica 7 gunluk i ise ----- Sari
Tarih 30 gunden buyuk ise ----- kahaverengi


Private Sub FormatListView1()
Dim Item As ListItem
Dim Counter As Long
Dim Note As String
Dim Tarih As String
Dim Color As Long
Dim N As Long

' Set the variable to the ListItem.
For Counter = 1 To Me.ListView1.ListItems.Count
Set Item = Me.ListView1.ListItems.Item(Counter)
' Set the variable to the Freight
Note = Item.SubItems(17)

Tarih = Item.SubItems(18)
With Me.ListView1
If Note <> "" Then
If Tarih = Date Then
Color = vbMagenta
ElseIf Tarih <> Date And Tarih = Date > 30 Then
Color = vbRed
ElseIf Tarih <> Date And Tarih = Date < 30 Then
Color = vbBlue
End If
Else
Color = vbBlack
End If
Item.ForeColor = Color
For N = 1 To 20
Item.ListSubItems(N).ForeColor = Color
Next N
End With
Next Counter
Me.ListView1.Refresh

End Sub
 
Merhaba
Aşağıdaki gibi deneyiniz.
Kod: 
[SIZE="2"]Private Sub FormatListView1()
Dim Item As ListItem
Dim Counter As Long
Dim Note As String
Dim Tarih As Date
Dim iColor As Long
Dim N As Integer
For Counter = 1 To Me.ListView1.ListItems.Count
Set Item = Me.ListView1.ListItems.Item(Counter)
iColor = vbBlack
Note = Item.SubItems(17)
Tarih = Item.SubItems(18)
With Me.ListView1
If Note <> "" Then
If Tarih < Date Then GoTo 2
Select Case Tarih
Case Is = Date: iColor = vbRed
Case Is < Date + 7: iColor = vbYellow
Case Is < Date + 30: iColor = vbBlue
Case Is > Date + 30: iColor = vbMagenta
End Select
End If
Item.ForeColor = iColor
For N = 1 To 20
Item.ListSubItems(N).ForeColor = iColor
Next N
2:
End With
Next Counter
Me.ListView1.Refresh
End Sub [/SIZE]
 
Cevap icin cok tesekkurler fakat calismadi.
Eger bu sirayi "Dim Tarih As Date" bu sekilde "Dim Tarih As String" olarak degistirirsem sadece bugunku gunler kirmizi oluyor onceki tarihlerin hepsi siyah.

Tarih 12/05/2016 formatinda "Listview.Item.SubItems(18)" kolonunda acaba bununla bir ilgisi olabilirmi?
 
Ekdeki dosya otamatik UserForm pencersi acar, Excel butonuna basip sonra excel sayfasini goreceksiniz ,oradan kodlama kismina bakip verdigim Kodu bulabilirsisniz ve sizing kodunuzu deneyebilirsiniz. Daha sonra excel sayafasindan Open Form butonuyla UserForm mu calistirabilirsiniz. Ayrica calistirdiktan sonra Show All butonuna birkere basmanizi tavsiye ederim cunku tarihleri ListView pencersinde otomatik olarak gostermiyor bu butona basmazsaniz. O da bir problem cozmem gereken. Vlookup otomatik update yapmiyor ama bu ayri bir konu.
 

Ekli dosyalar

Merhaba
Yukarıda ki kodlar "Listiew" de bulunan tarihe göre çalışıyor "S" sütunu listeye alınmalı
"Form initalize" içine eklenen: ".Add , , sh.Cells(1, 19), sh.Range("s1").Width"
yukarıdaki kodda değişen: "For N = 1 To 18"

Eklediğiniz dosya bende "Listview" farkından dolayı çalışmadı
ekteki yeni dosyada denedim
http://s4.dosya.tc/server/cma3xw/sample.zip.html
 
Degisiklikleri yaptim yine calismadi , ayrica : "Add , , sh.Cells(1, 19), sh.Range("s1").Width" gerek yok cunku tarih diger sayfadan bu sira ile aliniyor : ".Add , , Sh2.Cells(1, 3), sh.Range("C1").Width" . Bir de verdiginiz linki acamiyorum virus programi bloke ediyor.Dosya olarak atarmisinisz lutfen ?
cok tesekkurler ilginiz icin
 
lapot' Alıntı:
Degisiklikleri yaptim yine calismadi , ayrica : "Add , , sh.Cells(1, 19), sh.Range("s1").Width" gerek yok cunku tarih diger sayfadan bu sira ile aliniyor : ".Add , , Sh2.Cells(1, 3), sh.Range("C1").Width" . Bir de verdiginiz linki acamiyorum virus programi bloke ediyor.Dosya olarak atarmisinisz lutfen ?
cok tesekkurler ilginiz icin
Genişletmek için tıkla ...
Aşağıdaki linklerden bir bakın
http://s4.dosya.tc/server/sy1u2p/sample2.xls.html
http://dosya.co/u7levpvelj7o/sample2.xls.html
 
Egere bu sirayi:" Dim Tarih As Date" buna degistirirsem :"Dim Tarih As String" o zaman bazi siralar Magenta oluyor listviewde fakat 4/05/2016 tarihli sirasi siyah oluyor. Ekdeki resime bir bakin lutfen
 

Ekli dosyalar

  • Capture sample.jpg
    Capture sample.jpg
    16.3 KB · Görüntüleme: 2
lapot' Alıntı:
Tarih, Bugun ‘e esit ise ------ Kirmizi
Tarih, Bugun’e esit degil ve 30 gunden kucuk ise ----- mavi ve ayrica 7 gunluk i ise ----- Sari
Tarih 30 gunden buyuk ise ----- kahaverengi
Genişletmek için tıkla ...
Resmi göremem ama;
Sizin ilk mesajınızdan anladığım;
Bugüne eşitse kırmızı
Bugün+7 = 19/05/2016 kadar sarı
bugün+30 =12/06/2016 kadar mavi
12/06/2016 dan sonrası kahverengi demişsiniz
bugünden geri için ?

lapot' Alıntı:
4/05/2016 tarihli sirasi siyah oluyor.
Genişletmek için tıkla ...
 
Bugun esit ise Kirmizi
7 gunluk ise Sari
30 gun icindeki hepsi mavi (yanliz bu 7 gun olanida icine aliyor buradaki amacim her yedi gunde bir takip etme yapmam icin, belki bunu soyle ayirmamiz lazim 6 gunluk ve 8 ile 30 gun arasi mavi , boylece sadece 7 gun eski olan tarihleri sari yapar)
30 gunden eskiyse kahverengi seklinde yapmak istiyorum.

insallah anlatabildim
 
O halde kodlar şöyle değişmeli:
Boş listenin "Notes" sütunu boş olan ve bugünden ileri tarihli satırlar siyah
http://i.hizliresim.com/6P4azP.gif
Kod: 
Private Sub FormatListView1()
Dim Item As ListItem
Dim Counter As Long
Dim Note As String
Dim Tarih As[COLOR="Blue"] Date[/COLOR]
Dim iColor As Long
Dim N As Integer
For Counter = 1 To Me.ListView1.ListItems.Count
Set Item = Me.ListView1.ListItems.Item(Counter)
iColor = vbBlack
Note = Item.SubItems(17)
Tarih = Item.SubItems(18)
With Me.ListView1
If Note <> "" Then
[COLOR="Blue"]If Tarih > Date Then GoTo 2
Select Case Tarih
Case Is < Date - 30: iColor = vbMagenta
Case Date - 30 To Date - 8: iColor = vbBlue
Case Date - 7 To Date - 1: iColor = vbYellow
Case Is = Date: iColor = vbRed[/COLOR]
End Select
End If
Item.ForeColor = iColor
For N = 1 To [COLOR="Blue"]18[/COLOR]
Item.ListSubItems(N).ForeColor = iColor
Next N
2:
End With
Next Counter
Me.ListView1.Refresh
End Sub
 
Calisti fakat ne zamam yeni not eklsesm yada editlesem hata veriyor
"Type - mismatch 13" hatasi bu sirada " Tarih = Item.SubItems(18)"
Neden acaba?

Ugrastirdigim icin cok uzgunum ama nerdeyse haloldu
 
"Listview1"
"Item.SubItems(18)" boş kalıyor veya tarih değil,
Hata oluşan:
" Tarih = Item.SubItems(18)"
hemen üstüne:

Kod: 
'....kodlarınız
'....
Note = Item.SubItems(17)
[COLOR="Red"]If Item.SubItems(18) = "" Then GoTo 2[/COLOR]
Tarih = Item.SubItems(18)
With Me.ListView1 
'...
'......

veya
Kod: 
 Note = Item.SubItems(17)
[COLOR="Red"]If Item.SubItems(18) = "" And IsDate(Item.SubItems(18)) = False Then GoTo 2[/COLOR]
Tarih = Item.SubItems(18)
With Me.ListView1
 
Cok tesekkurler degisiklikler icin

" Note = Item.SubItems(17)
If Item.SubItems(18) = "" Then GoTo 2
Tarih = Item.SubItems(18)
With Me.ListView1"

Yukariki kisim calisti ama glaiba bir kismini tam aciklayamadim , sadece 7 gunluk olan tarihleri Sari yapmak istiyorum 1 ile 7 arasi olanlari degil.

Bu siralarda degisiklik yapmam lazim
"Case Date - 30 To Date - 8: iColor = vbBlue
Case Date - 7 To Date - 1: iColor = vbYellow"

Mumkunmu ?
 
lapot' Alıntı:
Bu siralarda degisiklik yapmam lazim
"Case Date - 30 To Date - 8: iColor = vbBlue
Case Date - 7 To Date - 1: iColor = vbYellow"
Genişletmek için tıkla ...
Kırmızı bölümü aşağıdaki (satırlarını da değiştirerek) gibi değiştirmeniz yeterlidir ("notes" sütununda ilgili satır dolu olmalı)
Kod: 
Case Date - 7: iColor = vbYellow
Case Date - 30 To Date - 1: iColor = vbBlue
 
Son düzenleme:
En son hali bu ama yine istedigim sonucu alamadim simdi hic Sari sira yok, Sari siralar siyah oldu, bayagi ugrastirdim sizi kusura bakmayin

"Dim Item As ListItem
Dim Counter As Long
Dim Note As String
Dim Tarih As Date
Dim iColor As Long
Dim N As Integer
For Counter = 1 To Me.ListView1.ListItems.Count
Set Item = Me.ListView1.ListItems.Item(Counter)
iColor = vbBlack
Note = Item.SubItems(17)
If Item.SubItems(18) = "" Then GoTo 2
Tarih = Item.SubItems(18)
With Me.ListView1
If Note <> "" Then
If Tarih > Date Then GoTo 2
Select Case Tarih
Case Is < Date - 30: iColor = vbMagenta
Case Date - 30 To Date - 8: iColor = vbBlue
Case Date - 7: iColor = vbGreen
Case Is = Date: iColor = vbRed
End Select
End If
Item.ForeColor = iColor
For N = 1 To 18
Item.ListSubItems(N).ForeColor = iColor
Next N
2:
End With
Next Counter
Me.ListView1.Refresh
End Sub"
 
lapot' Alıntı:
En son hali bu ama yine istedigim sonucu alamadim simdi hic Sari sira yok, Sari siralar siyah oldu, bayagi ugrastirdim sizi kusura bakmayın
Genişletmek için tıkla ...
Rica ederim, asıl hata benim son mesajı geç düzeltmemden olmuş siz kusura bakmayın, aşağıdaki kırmızı bölümlerin satırları değişik olacak ve "Date - 1" olacaktı
bu şekilde deneyin. ("notes" sütununda ilgili satır dolu olmalı)
Kod: 
Private Sub FormatListView1()
Dim Item As ListItem
Dim Counter As Long
Dim Note As String
Dim Tarih As Date
Dim iColor As Long
Dim N As Integer
For Counter = 1 To Me.ListView1.ListItems.Count
Set Item = Me.ListView1.ListItems.Item(Counter)
iColor = vbBlack
Note = Item.SubItems(17)
If Item.SubItems(18) = "" Then GoTo 2
Tarih = Item.SubItems(18)
With Me.ListView1
If Note <> "" Then
If Tarih > Date Then GoTo 2
Select Case Tarih
Case Is < Date - 30: iColor = vbMagenta
[COLOR="Red"]Case Date - 7: iColor = vbYellow
Case Date - 30 To Date - 1: iColor = vbBlue[/COLOR]
Case Is = Date: iColor = vbRed
End Select
End If
Item.ForeColor = iColor
For N = 1 To 18
Item.ListSubItems(N).ForeColor = iColor
Next N
2:
End With
Next Counter
Me.ListView1.Refresh
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst