Jeg kan også sagtens få betinget formatering til at virke, men i mit ark har jeg en masse andre funktioner, bla. til at indsætte, slette og flytte linier -og det kan den betingede formatering ikke lide og eks. hvis jeg har slettet en linie og senere indsat en ny, vil den betingede formatering ikke huske det..
Derfor tænker jeg, at det må være muligt at lave et check på cellerne C1:C200, og farve alle datoer der er mindre end 14 fremme i tiden røde, og resten skal være ufarvede.
Hvis funktionen automatisk kørte hver gang man åbnede dokumentet ville de være den bedste løsning da man så ikke er afhængig af at folk aktivere check'et.
Placér nedenstående i et modul og kald proceduren fra Workbook_Open.
Public Sub ColorCells() Dim objRange As Range Dim objCell As Range Dim lngCell As Long
Set objRange = ActiveWorkbook.Sheets(1).Range("C1", "C200")
objRange.Interior.Pattern = xlNone
For lngCell = 1 To objRange.Cells.Count Set objCell = objRange.Cells(lngCell) If IsDate(objCell.Value) Then If objCell.Value - Date < 14 Then objCell.Interior.Color = 255 End If End If Next lngCell
Sub test() For t = 1 To 200 If Cells(t, 3) < Now + 14 Then Cells(t, 3).Interior.ColorIndex = 3 Else Cells(t, 3).Interior.ColorIndex = xlNone End If Next End Sub
#word-hajen I mine øjne ser det ud til at være et godt forslag, men den laver debug-fejl i:
objRange.Interior.Pattern = xlNone
#excelent Når jeg kører din funktion bliver alle blanke felter i kolonnen farvet røde, mine datofelter sker der ikke noget med- hvis jeg bytter om på 3 og xlNone bliver alle mine datoer røde og alle blanke felter hvide. Den læser vist ikke datoen som en dato (og jeg har tjekket formatering af cellerne).
Sub test() For t = 1 To 200 If Cells(t, 3) <> "" And IsDate(Cells(t, 3)) And Cells(t, 3) <= Date + 14 Then Cells(t, 3).Interior.ColorIndex = 3 Else Cells(t, 3).Interior.ColorIndex = xlNone End If Next End Sub
Sub Termin() For Each c In Sheets("Ark4").Range("C1:C200") If IsDate(c) And c < Now + 14 Then c.Interior.ColorIndex = 3 Else c.Interior.ColorIndex = xlNone End If Next End Sub
#word-hajen Får/fik en Run time error 1004, App. defined or object defined error. Jeg fandt lige ud af at det var fordi din kode stod til sheet(1), og jeg arbejder med flere sheets, så jeg havde kun nr. 3 åbent. Den skal så lige hedde activesheet i stedet :)
Men derudover ser den ikke ud til at gøre det helt rigtigt. I kolonnen har jeg bla. datoerne (jeg har forsøgt både at formatere dem som ddmmyyyy og ddmmyy m.m., ser kun ud til at reagere på ddmmyy):
af disse bliver 01.06.07, 17.3.07, 01.01.07 og 02.05.07 røde, resten blanke. Formateringen er ens hele vejen ned.. Hvis jeg i et af de felter der er blanke, skriver eks. 01.01.07 og køre makroen, så bliver denne farvet. Den forstår altså tallene forkert når den trækker 14 fra/til.
#kabbak Den laver bare linierne blanke. Har også forsøgt med at formatere alle celler på forskellige måde
Jeg får en run-time error 438, Object doesnt support this property or method.
Jeg ændrede koden til:
Sub Termin() For Each c In ActiveSheet.Range("C1:C200") If IsDate(c) And c < Now + 14 Then c.Interior.ColorIndex = 3 Else c.Interior.ColorIndex = xlNone End If Next End Sub
Men den ser ikke ud til at gøre noget.. Det kunne se ud til jeg skulle sende det til en af jer måske?
prøv denne - den udskifter punktum (.) med bindestreg (-) først
Sub Termin() ActiveSheet.Range("C1:C200").Select Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart For Each c In ActiveSheet.Range("C1:C200") If IsDate(c) And c < Now + 14 Then c.Interior.ColorIndex = 3 Else c.Interior.ColorIndex = xlNone End If Next End Sub
Noget skete der i hvertfald, nu er der noget der bliver farvet. Det er stadig som om datoformatet er forkert. Ud af den liste herunder er der 4 der bliver røde -de er alle rigtige, men der er også en del der bør blive som ikke bliver.
25.10.2006 Bliver rød, ok 02.11.2007 17-03-2007 20-04-2007 30-04-2007 20-05-2007 01.01.2007 Bliver rød, ok 01.09.2007 24-01-2007 18-06-2007 01.01.2007 Bliver rød, ok 04.10.2007 05.02.2007 Bliver rød, ok 21-05-2007 04.06.2007 07.08.2007 04.09.2007 09.07.2007 09.08.2007 09.08.2007 09.08.2007 18-09-2007 23-09-2007 24-09-2007
Hvilken formatering benytter du? Jeg kan evt sende en fil i morgen så du kan se konteksten af det.. du siger bare til. Ihvertfald mange tak for hjælpen indtil nu, det skal nok lykkedes ;)
Det er fuldstændig rigtigt, at en "dato" med punktummer ikke bliver opfattet som en dato. Du skal derfor have en replace på punktummet i koden.
Nedenstående udskifter punktummet, men kun i koden så du kan beholde dine datoer med punktummer i dit ark, hvis det nu er det, du gerne vil.
Public Sub ColorCells() Dim objRange As Range Dim objCell As Range Dim lngCell As Long Dim strDate As String
Set objRange = ActiveSheet.Range("C1", "C200")
objRange.Interior.Pattern = xlNone
For lngCell = 1 To objRange.Cells.Count Set objCell = objRange.Cells(lngCell) strDate = Replace(objCell, ".", "-") If IsDate(strDate) Then If CDate(strDate) - Date < 14 Then objCell.Interior.Color = 255 End If End If Next lngCell
Set objCell = Nothing Set objRange = Nothing End Sub
ps! Hvis du vil have koden til at køre, når du åbner filen, er ActiveSheet en dårlig løsning. Så skal du i hvertfald sørge for, at det altid er det rigtige ark, der er aktiveret (hvis filen indeholder flere ark), inden koden afvikles.
hvis du indsætter koden i ThisWorkbook, så kører koden når du åbner projektmappen du skal nok lige ændre Activesheet til Sheets(" dit ark ")
Private Sub Workbook_Open()
ActiveSheet.Range("C1:C200").Select Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart For Each c In ActiveSheet.Range("C1:C200") If IsDate(c) And c < Now + 14 Then c.Interior.ColorIndex = 3 Else c.Interior.ColorIndex = xlNone End If Next
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
