Jack,
My code is already made, so it will only make the date red if it is
fond in colum I or J. The challenge is your formula. If we go back and
use my original formula, it will always find the most future date, and
the code will color it as required. I am not sure if this is needed.
Insert the code below before 'Columns("L").Clear' to fill P2 and down:
Set f = Range("L2:L" & LastRow).Find(what:=2, After:=Range("L2"), _
LookIn:=xlValues, Lookat:=xlWhole)
MyFormula = "=A2 & B2 & Text(K2, ""d mmmm yyyy"")"
Range("P2").Formula = "=A2 & B2 & Text(K2, ""d mmmm åååå"")"
Range("P2
" & f.Row - 1).FillDown
Regards,
Per
"Jack Sons" <
[email protected]> skrev i meddelelsen
Per,
It occurred to me that column H could have a more future date than in
the date in the corresponding cells of I or J. In that case the H-date
should be in K, but in black and regular. You see, red in K means an
action date for me. A date in H is not an action date for me, even if
it is more future than I or J (I and J in that case wil be dates that
already are in the past).
Can you fix that also?
Jack.
"Per Jessen" <
[email protected]> schreef in bericht
Jack,
Your code do not look to bad, but you do not need to use .Select when
you manipulate a cell. I removed all select statements, and then it
looks like this (the Calculate statement is only needed if you use
manual calculation):
Sub jack2()
Range("K2").FormulaR1C1 = _
"=IF(MAX(RC[-5],RC[-3]:RC[-1])>0,MAX(RC[-5],RC[-3]:RC[-1]),IF(MAX(RC[-7]:RC[-6],RC[-4])>0,MAX(RC[-7]:RC[-6],RC[-4]),""""))"
Range("L2").FormulaR1C1 = _
"=IF(AND(MAX(RC[-8]:RC[-7],RC[-6]),RC[-1]>TODAY()),""xx"",IF(OR(AND(RC[-1]<>0,RC[-1]<TODAY()),RC[-1]=TODAY()),""x"",""""))"
Range("K2:L2").AutoFill Destination:=Range("K2:L252"),
Type:=xlFillDefault
Columns("K:K").NumberFormat = "d mmmm yyyy"
Calculate
Range("A2").Sort key1:=Range("L2"), order1:=xlDescending,
Key2:=Range("I2") _
, Order2:=xlAscending, Key3:=Range("K2"), Order3:=xlAscending,
header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom
With Columns("K:K")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression,
Formula1:="=en(OF($K1=$I1;$K1=$J1);$K1>VANDAAG())"
With .FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 3
End With
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$K1<=VANDAAG()"
With .FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 5
End With
End With
End Sub
Just curious does your macro sort correct if you have the most future
date in column J?
No problem using your formula in my code, just replace:
Range("K2").Formula = "=Max(D2:J2)"
With:
Range("K2").FormulaR1C1 = _
"=IF(MAX(RC[-5],RC[-3]:RC[-1])>0,MAX(RC[-5],RC[-3]:RC[-1]),IF(MAX(RC[-7]:RC[-6],RC[-4])>0,MAX(RC[-7]:RC[-6],RC[-4]),""""))"
and insert the statement below to format column K.
Columns("K:K").NumberFormat = "d mmmm yyyy"
You can always come back for further help.
As you see my macro put 1, 2 or 3 in column L which is only used for
primary sort key, then I use Column K as secondary sort key.
Regards,
Per
"Jack Sons" <
[email protected]> skrev i meddelelsen
Per,
Thanks again.
Remarkable is that I also used column L as helper column. With the
code below the dotted line I did - I think - something slightly
different regarding putting a date in column K. Or didn't I? The
results of your code and mine look the same!
If I did, can you make your code do for placing dates in column K
equal to what I did with the first R1C1 formula below?
In column L my code put "xx" where a K-cell should be red and bold,
"x" where it should be black and regular and blank where it shoud be
blue and bold. (later on I filter out the superfluous rows, that is
those rows where in column DM is "x", see my first post that you
answered). Notice that in the lower half of my code VANDAAG is Dutch
for TODAY.
Your code is undeniable much more elegant than mine, I use rather
primitively looking code aid due to the fact that I did not yet
master the for ... next loop. But it worked also! (does it look very
bad?)
Thanks again for your help Per. Hope you will help me again when I
have additional questions.
Jack.
--------------------------------------------------------------------------------------------------------------------
Range("K2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(MAX(RC[-5],RC[-3]:RC[-1])>0,MAX(RC[-5],RC[-3]:RC[-1]),IF(MAX(RC[-7]:RC[-6],RC[-4])>0,MAX(RC[-7]:RC[-6],RC[-4]),""""))"
Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(MAX(RC[-8]:RC[-7],RC[-6]),RC[-1]>TODAY()),""xx"",IF(OR(AND(RC[-1]<>0,RC[-1]<TODAY()),RC[-1]=TODAY()),""x"",""""))"
Range("K2:L2").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("K2:L252"),
Type:=xlFillDefault
Range("K2:L252").Select
Columns("K:K").Select
Selection.NumberFormat = "d mmmm yyyy"
Calculate
Range("A2").Select
Selection.Sort key1:=Range("L2"), order1:=xlDescending,
Key2:=Range("I2") _
, Order2:=xlAscending, Key3:=Range("K2"), Order3:=xlAscending,
header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom
Columns("K:K").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression,
Formula1:="=en(OF($K1=$I1;$K1=$J1);$K1>VANDAAG())"
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 3
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$K1<=VANDAAG()"
With Selection.FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 5
End With
"Per Jessen" <
[email protected]> schreef in bericht
Jack,
You can improve the previous code a bit further:
With DestSh
.Shapes("resteert").Delete
.Shapes("betaald").Delete
.Shapes("legenda_1").Delete
.Shapes("L").Delete
End With
I do not hope you have any data in column L as it is used as helper
column in the macro below. I think this is what you asked for:
Sub Jack()
Dim LastRow As Long
Dim cell As Range
Application.Screenupdating=False
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("K2:K" & rows.Count).Clear
Range("K2").Formula = "=Max(D2:J2)"
Range("K2:K" & LastRow).FillDown
For Each cell In Range("K2:K" & LastRow).Cells
If cell.Value < Date Then
cell.Font.Bold = True
cell.Font.ColorIndex = 5
cell.Offset(0, 1) = 3
ElseIf cell.Value = cell.Offset(0, -1) Or _
cell.Value = cell.Offset(0, -2) Then
With cell
.Font.Bold = True
.Font.ColorIndex = 3
.Offset(0, 1) = 1
End With
Else
cell.Offset(0, 1) = 2
End If
Next
Range("A2:L" & LastRow).Sort Key1:=Range("L2"), _
Order1:=xlAscending, Key2:=Range("K2"), _
Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Columns("L").Clear
Application.Screenupdating=True
End Sub
-Per
Yes Per, I used that, thanks.
Now I would like to use nice compact and fast executing code for the
following complex conditions.
Row 1 contains headers.
Cells in colums D to J (from row 2 downwards, as far below as there
are
names in column A) contain dates or nothing.
In each row I want in column K the "highest" (most future) date but
in bold and red if it is a future date of colums I or J
in regular and black if is a future date of colums D to H
in bold and blue if it is a date in the past
and
the rows with a bold and red date in column K sorted ascending to
the
dates in column K
the rows with a ragular and black date in column K sorted ascending
to
the dates in column K
the rows with a bold and blue date in column K sorted ascending to
the
dates in column K
So column K will look like a red, blach and blue flag, like shown
below
(hope it will show after sending it over internet, colors are red
for the
first four dates, black for the following three and blue for the
last five).
8 oktober 2009
14 oktober 2009
9 november 2009
11 november 2009
7 oktober 2009
9 oktober 2009
9 oktober 2009
28 augustus 2009
22 september 2009
25 september 2009
30 september 2009
30 september 2009
Thank you in advance Per.
Jack.
"Per Jessen" <
[email protected]> schreef in
bericht
Jack,
You are close, but no need to select the shapes:
DestSh.Shapes("resteert").Delete
DestSh.Shapes("betaald").Delete
DestSh.Shapes("legenda_1").Delete
DestSh.Shapes("L").Delete
Per
"Jack Sons" <
[email protected]> skrev i meddelelsen
Per,
If you change the code to copy row 1 also and paste starting in
row 1
I did this
With TargetSh
.Range("DM1
M" & eindrij).AutoFilter field:=1, Criteria1:="<>x"
.Range("A1:C" & eindrij).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("A1")
.Range("F1:F" & eindrij).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("N1")
.Range("AA1:AA" & eindrij).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("O1")
...
.Range("DM1
M" & eindrij).AutoFilter
End With
but then the text boxes come with the cells of row 1 of TargetSh.
I got rid of them with
DestSh.Shapes("resteert").Select
Selection.Delete
DestSh.Shapes("betaald").Select
Selection.Delete
DestSh.Shapes("legenda_1").Select
Selection.Delete
DestSh.Shapes("L").Select
Selection.Delete
which is rather clumsy, I'm afraid (better: I'm sure).
What now?
Jack.
"Per Jessen" <
[email protected]> schreef in bericht
Jack,
I am glad you learned a bit from my code.
If you change the code to copy row 1 also and paste starting in
row 1,
the textbox will not be copied, neither will the content of the
textbox.
You can place the content of the textbox in the underlying cell.
To do
that, enter design mode, and right click a textbox > Properties
Find
LinkedCell property, and enter the cell address, eg. A1, then
you just
change the code to copy/paste starting at row 1
.Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("A1")
Hopes this helps.
...
Per
"Jack Sons" <
[email protected]> skrev i meddelelsen
Per,
Thank you. So much of my own clumsy code I can now discard! I
really
learned a thing or two (or more)!
What if I also want to bring the cells in row 1 of the columns
mentioned to the destination sheet and I do not want the
textboxes that
exist in row 1 of the targetsheet to be copied to the
destination
sheet?
Jack.
"Per Jessen" <
[email protected]> schreef in bericht
Hi
I think this is what you need:
Sub aaa()
Dim TargetSh As Worksheet
Dim DestSh As Worksheet
Dim LastRow As Long
Application.ScreenUpdating = False
Set TargetSh = Worksheets("Sheet1")
Set DestSh = Worksheets("Sheet2")
LastRow = 252
With TargetSh
.Range("DM1
M" & LastRow).AutoFilter field:=1,
Criteria1:="<>x"
.Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("A2")
.Range("D2
" & LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("N2")
.Range("AA2:AA" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("O2")
.Range("AK2:AL" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("D2")
.Range("AM2:AM" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("G2")
.Range("AN2:AN" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("F2")
.Range("AO2:AO" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("J2")
.Range("AP2:AP" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("H2")
.Range("AR2:AR" &
LastRow).SpecialCells(xlCellTypeVisible).Copy
DestSh.Range("I2")
.Range("DM1
M" & LastRow).AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Regards,
Per
"Jack Sons" <
[email protected]> skrev i meddelelsen
Hi all,
Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy
columns A to C to sheet 2 colums A to C rows 2 and further,
column D to sheet 2 colum N rows 2 and further,
column AA to sheet 2 column O rows 2 and further,
columns AK and AL to sheet 2 colums D and E rows 2 and
further,
column AM to sheet 2 column G rows 2 and further,
column AN to sheet 2 column F rows 2 and further,
column AO to sheet 2 column J rows 2 and further,
column AP to sheet 2 column H rows 2 and further,
column AR to sheet 2 column I rows 2 and further,
and all that only for those rows where in column DM is not an
"x".
Formats, text colors and interior colors are also to be
copied.
Due to clumsy code (sorry for that) I can't change the order
of the
columns in sheet 1 without getting an awful lot of trouble.
I'm looking for nice compact and fast executing code, your
assistance
will be appreciated.
Jack Sons
The Netherlands- Skjul tekst i anførselstegn -
- Vis tekst i anførselstegn -
