I want to insert a timestamp (E3) when the status (B3) changes. This should happen for at least 30 more such examples in the worksheet. The code currently works only for one example (Country1). Do you have an idea how this can be implemented?
I already tried different types but it just worked for example "Country 1" not for "Country 1", "Country 2", "Country 3" etc.
When I adjust the code for the range "B3:I3" then I received an adjustment in every 3rd column, example: I add a comment in D3 then a timestamp will be created in H3. That is not what I want. :(
Is there a way to adjust the code so that as soon as a change is made in the Status column (B3;F3;J3etc.), the Timestamp column (E3;I3 etc.) will reflect the time stamp?
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3:B5"))
Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Offset(0,3).Value = Now
Application.EnableEvents = True
Please, try the next adapted event. It will calculate how many groups of four columns exists and set a range of their first column intersected with rows 3 to 5. Only for this range the event will be triggered:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastCol As Long, rngCols As Range
lastCol = Me.cells(2, Me.Columns.count).End(xlToLeft).column 'last column on the second row
Set rngCols = Me.Range(trigData(Me.Range("B2", Me.cells(2, lastCol)))) 'create the range of the columns for what the event to be triggered
Set rngCols = Intersect(Me.rows("3:5"), rngCols) 'create the range inside which the change to trigger the event
If Not Intersect(rngCols, Target) Is Nothing Then
Application.EnableEvents = False
Target.Offset(0, 3).Value = Now
Application.EnableEvents = True
End If
End Sub
Function trigData(rngCols As Range) As String
Dim i As Long, strCols As String
For i = 1 To rngCols.Columns.count Step 4 'iterate from four to four and create the necessary columns string address
strCols = strCols & "," & rngCols.cells(i).EntireColumn.address
Next i
trigData = Mid(strCols, 2) 'Mid eliminates the first (unnecessary) comma...
End Function
The code will be confused if you place on the second row data after the necessary groups of four columns. If necessary, one or two such columns, the code can be adapted to work for a fix number extracting the divided integer (without decimals).
The code assumes that you need to be triggered for the mentioned rows (3 to 5). If you need something different in terms of rows to be affected, you should change Me.rows("3:5") according to your need.
Please, send some feedback after testing it.
Your request is a little unclear, and your table format may not have come across correctly in your post. Your code is written to add the current time to a cell 3 columns away from the target cell. It is dynamic, so if you set
If Intersect(Target, Range("B2:I3"))
You are going to get the value in cell 3 columns offset from the changed cell. If you always want it to update column E, then you can use the target.row property...
Cells(Target.Row,5).Value = Now
...to make the row dynamic, and the column static. Clarify your question if this is not what you're looking for. If country2 is in cell F2, where do you want to write the timestamp?
You can use this simple function:
Public Function TimeStamp(Status As Range) As Double
TimeStamp = Now
End Function
So, in Cell E3 will be the formula =TimeStamp(B3). (Format cell E3 appropriately as Time Format)
Related
I have an Excel sheet with prices (of materials used in construction) from previous years.
I am trying to make a code that will show me all the data based on a certain year that I choose.
What my list/excel looks like
In cell E3 (in yellow), I input the year to "analyse".
I need a function that will search columns K to Q (and more since every year, prices change), for that year, and copy all the data of sales, reg. loc. and spec. loc. into the columns F, G and H.
If it's easier that, instead of putting the year in cells K3, L3 and M3 (for example), if I put it in cell N3, R3, etc. (in red) instead, the function will take the 3 previous columns and copy/paste them in columns F to H.
Option 2, if it makes the coding easier
Also the list goes until row 381, and there's a potential that more data will be input eventually so take into consideration as if the list had an infinite amount of rows. However, for the columns, it's always fixed to 3 columns.
FYI: it is not a school project. I'm trying to simplify my work instead of manually searching and copy/pasting the data every time.
Please, try the next code. It should do what (I understand) you need. It should be fast, not using clipboard for copying. As I suggested in my comment, it firstly searches/finds in the third row the year (long or string, as it is written in "E3"), starting searching after "E3", then copying the range built according to the found cell. If not a match is found, the code exits on the line If rngFirstCol Is Nothing Then Exit Sub. You may place a message there, to warn in such a case. It works on your first arrangement/picture, meaning that the year must be filled in the third row of the first column where from the necessary data should be collected/copied:
Sub ExtractPricesPerYear()
Dim sh As Worksheet, lastR As Long, rngFirstCol As Range, lngYear, necCol As Long
Set sh = ActiveSheet 'use here your necessary sheet
lngYear = sh.Range("E3").value 'the year to be searched
Set rngFirstCol = sh.rows(3).Find(What:=lngYear, After:=sh.Range("E3"), LookIn:=xlValues, Lookat:=xlWhole)
If rngFirstCol Is Nothing Then Exit Sub
necCol = rngFirstCol.Column
lastR = sh.cells(sh.rows.count, necCol).End(xlUp).row
With sh.Range(rngFirstCol.Offset(1), sh.cells(lastR, necCol + 2))
sh.Range("E4").Resize(.rows.count, .Columns.count).value = .value
End With
End Sub
Please, send some feedback after testing it.
And another issue: It is good to show us what you tried by your own. If not a piece of code, at least, something to prove that you investigated and had some ideas about the task to be solved, asking for hints, suggestions etc. proving that you know something about how it can be done...
Edited:
Following your requirement from last comment, please use the next solution. Please, copy the next code in the respective sheet code module (right click on the sheet name, then choose View Code):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, lastRF As Long, rngFirstCol As Range, lngYear, necCol As Long
If Target.Address(0, 0) = "E3" Then 'the code exits for any other change on the sheet
lngYear = Target.value 'the year to be searched
Set rngFirstCol = Me.rows(3).Find(What:=lngYear, After:=Me.Range("E3"), LookIn:=xlValues, Lookat:=xlWhole)
If rngFirstCol Is Nothing Then MsgBox "No such year found on the third row...:": Exit Sub
necCol = rngFirstCol.Column 'column number of the found cell
lastR = Me.cells(Me.rows.count, necCol).End(xlUp).row 'last row on the found column
lastRF = Me.Range("F" & Me.rows.count).End(xlUp).row 'last row on F:F column (to delete its content, if any)
If lastRF > 4 Then Me.Range("F4:H" & lastRF).ClearContents 'clear the range to make place for the new data
With Me.Range(rngFirstCol.Offset(1), Me.cells(lastR, necCol + 2))
Me.Range("F4").Resize(.rows.count, .Columns.count).value = .value
End With
End If
End Sub
I have a bunch of choices that can be made in the cells (C41:C59) using a dropdown, the value of the dropdown also is seen in the cells (E41:E59). For each choice I want different rows to show or hide. Hide if the dropdown is N/A else show the rows. The problem i can't get around is that every choice has different rows and als a different amount of rows. So I tried to make a code per choice and only change this when the cell in column E changes. This is what I have so far, but doesn't do anything.
If Not Application.Intersect(Target, Range("E41")) Is Nothing Then
If Range("E41") = "N/A" Then
[67:73].EntireRow.Hidden = True
Else
[67:73].EntireRow.Hidden = False
End If
End If
The code below is an event procedure. It runs when a cell is changed on the worksheet in whose code sheet the procedure is found. (The location of the code in that particular module is paramount.) If a single cell was changed - ignoring multiple simultaneous changes such as might be caused by copy/paste action - the code will check if the modified cell was in the ranges C41:C59 or E41:E59. If so, it will hide or show rows in the same worksheet depending upon whether or the cell's value is "N/A" after modification.
Private Sub Worksheet_Change(ByVal Target As Range)
' 010
Dim TriggerRange As Range
Dim Rng As Range
' ignore simultaneous changes of many cells
If Target.Cells.CountLarge > 1 Then Exit Sub
Set TriggerRange = Application.Union(Range("C41:C59"), Range("E41:E59"))
If Not Application.Intersect(TriggerRange, Target) Is Nothing Then
Select Case Target.Row
Case 41, 46, 59
Set Rng = Range("67:73")
Case 50 To 59
Set Rng = Range(Rows(67), Rows(73))
Case Else
Set Rng = Range(Rows(67), Rows(73))
End Select
Rng.Rows.Hidden = (Target.Value = "N/A")
End If
End Sub
In this code always the same rows are hidden or shown. The code serves to demonstrate how you could specify different row ranges depending upon which row the changed cell is in, using different syntax depending upon your preference.
I need help in making some kind of dynamic color scaling in excel.
I need to scale one column but based on the values from other column. Actually, I need to reset the color scaling to the second column whenever value on the first column changes.
Unless I've misunderstood, seems like you want value-specific conditional formatting.
So all rows in column A that contain value Value1 should have their own colour scale in column B.
Similarly, all rows in A that contain value Value2 should have their own colour scale in column B.
And so forth for all remaining values in column A.
One approach to do this might involve VBA and consist of the following.
You can get all rows where column A contains a certain value (e.g. Value1) with Range.AutoFilter in conjunction with Range.SpecialCells.
You can add conditional formatting with Range.FormatConditions.Add.
It makes sense to complete the above two steps only once for each unique value. Otherwise, the steps will be completed for every value in column A.
You can get code to run when a change occurs in column A using Worksheet_Change event and some conditional IF logic.
Assuming your values in column A are sorted (as they appear to be in the document you've shared), the code might look something like:
Option Explicit
Private Sub ApplyValueSpecificConditionalFormatting(ByVal columnToFormat As Variant)
Dim filterRangeIncludingHeaders As Range
Set filterRangeIncludingHeaders = Me.Range("A1", Me.Cells(Me.Rows.Count, columnToFormat).End(xlUp))
Dim filterRangeExcludingHeaders As Range
Set filterRangeExcludingHeaders = filterRangeIncludingHeaders.Offset(1).Resize(filterRangeIncludingHeaders.Rows.Count - 1)
filterRangeExcludingHeaders.Columns(columnToFormat).FormatConditions.Delete ' Prevent redundant/obsolete rules.
' In your case, values in column A appear to be sorted. So we can assume that whenever
' the current row's value (in column A) is not the same as the previous row's value (in column A),
' that we have a new, unique value -- for which we should add a new colour scale in column B.
' A better, more explicit way would be to build a unique "set" of values (possibly accomodating
' type differences e.g. "2" and 2), and loop through the set.
Dim inputArray() As Variant
inputArray = filterRangeIncludingHeaders.Value
Dim rowIndex As Long
For rowIndex = (LBound(inputArray, 1) + 1) To UBound(inputArray, 1)
If inputArray(rowIndex, 1) <> inputArray(rowIndex - 1, 1) Then
filterRangeIncludingHeaders.AutoFilter Field:=1, Criteria1:=inputArray(rowIndex, 1)
Dim cellsToFormat As Range
On Error Resume Next
Set cellsToFormat = filterRangeExcludingHeaders.Columns(columnToFormat).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not (cellsToFormat Is Nothing) Then
' Probably best to put the below in its own function.
With cellsToFormat.FormatConditions.AddColorScale(colorscaleType:=2)
.SetFirstPriority
.ColorScaleCriteria(1).Type = xlConditionValueLowestValue
.ColorScaleCriteria(1).FormatColor.Color = vbWhite
.ColorScaleCriteria(2).Type = xlConditionValueHighestValue
.ColorScaleCriteria(2).FormatColor.Color = 8109667
End With
End If
Set cellsToFormat = Nothing
End If
Next rowIndex
Me.AutoFilterMode = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
ApplyValueSpecificConditionalFormatting columnToFormat:=2 ' or B
ApplyValueSpecificConditionalFormatting columnToFormat:="C" ' or 2
End If
End Sub
The code should be placed in the code module of the worksheet (containing values in column A and colour scales in column B).
I'm making this more challenging in my head than it has to be, but since I haven't been using vba or excel recently I'm using this as my excuse. Please don't question the methodology :) as this is only a small step I'm trying eliminate for someone to save some time, until I can redo the entire process. I would do the reverse, but this is an invoice of sorts that they are using....
I'm thinking macro or function is what is needed and not a formula since the data on worksheet 2 will change each month and there is no date I can reference.
What I'd like to do:
I have a cell on worksheet 2 that will change once a month. I want to place the value of the cell from Worksheet 2 into a cell in worksheet 1 each month that she changes it.
Each month would be represented in column A and the value of the cell from Worksheet 2 during that month needs to be place in column B.
Column A Column B
12/5/2012 $3,459,877.81
1/8/2013 $9,360,785.62
2/8/2013
3/8/2013
4/8/2013
So when she changes worksheet 1 for February the number will populate next to 2/8 and so on. I was thinking do it when she saves the document, or make it a shortcut she can hit or just scrap it and tell her it's not worth.
Giving a Cell a name to reference from you can do some neat stuff with the Target parameter passed to the Worksheet_Change function:
'Add this function to the sheet that has the cell being
'+changed by the user (Sheet 2)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strCellName As String
strCellName = "ChangeMe"
'If the cell we changed was the ChangeMeCell
If Target.Address = Sheet2.Range(strCellName).Address Then
'Store value
Dim intLastRow, intValue As Integer
intValue = Range(strCellName).Value
'Find the cell in Sheet 1 Column A that matches this month
intLastRow = Sheet1.Range("A:A").End(xlDown).Row
For Each cl In Sheet1.Range("A1:A" & intLastRow).Cells
'Ensure cell value is date
If IsDate(cl.Value) Then
'If date is today's date
'Note that Math.Round(<date>, 0 ) essentially removes the time
'+from any date value so #01/02/03 04:05:06# becomes #01/02/03#
If Math.Round(cl.Value,0) = Math.Round(Now,0) Then
'Update column B's value
Sheet1.Range("B" & cl.Row).Value = intValue
End If
End If
Next
End If
End Sub
This assumes you have the sheet layout with the "invoice values" in Sheet1 and the cell being changed in Sheet2. You need to give that cell a name.
Using the cell Name box to the left of the Function bar call the cell that changes "ChangeMe" or anything you wish to change it to, update that cell name in the first line of the function and this function will do all the rest.
It is important to note that the dates must be correctly formatted for your systems region. to make sure it is showing the right month - format them into LongDate so you can see them as 08 March 2013 instead of 03/08/13 which may get confusing the longer it goes on. Speaking as a British programmer, dates are the bane of my life!
Edit: I have update the code to compare the dates by the full date minus the time, instead of the previous monthly comparison, if you still need to subtract or add a month to either date value, just use the DateAdd("m", <date>, <value>) to add or subtract the month.
Edit: DatePart Function page is a useful resource for those wanting to know more about DatePart()
For my example, I'm using cell G4 as the one that will be updated by your coworker. You have to have some way to persist the original value of G4 in order to tell when it's been changed. The easy way to do this is to pick some cell that is out of sight of the user and store the number there so you can reference it later. Here I've chosen cell AA1. The following code must be added specifically to Sheet2 since it needs to monitor the changed events on that sheet only so it can fire when G4 is updated.
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("G4") <> Range("AA1") Then
Dim lastRow As Long
Range("AA1") = Range("G4")
lastRow = Worksheets("Sheet1").UsedRange.Rows.Count
Worksheets("Sheet1").Cells(lastRow + 1, 1).Value = Date
Worksheets("Sheet1").Cells(lastRow + 1, 2).Value = Range("AA1")
End If
End Sub
Keep in mind that this is a very "quick and dirty" approach for this task, as there are no error handlers or much flexibility in the way it works.
EDIT --
One other method you could use is referenced here, and can simply check to see if a given cell has changed, without verifying the difference in value.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Range("G4"), Range(Target.Address)) Is Nothing Then
Dim lastRow As Long
Range("AA1") = Range("G4")
lastRow = Worksheets("Sheet1").UsedRange.Rows.Count
Worksheets("Sheet1").Cells(lastRow + 1, 1).Value = Date
Worksheets("Sheet1").Cells(lastRow + 1, 2).Value = Range("AA1")
End If
End Sub
Now, I'm able to capture the value from a formula in the cell and place it in a different cell in another worksheet. Here's my final product:
Private Sub Worksheet_Calculate()
Dim strCellName As String
strCellName = "ChangeMe"
If Sheets("Application of Moneys").Range(strCellName).Address <> PrevVal Then
Dim intLastRow, intValue As Long
intValue = Range(strCellName).Value
'Find the cell in Sheet 1 Column A that matches this month
intLastRow = Sheets("Certificate 1").Range("B:B").End(xlDown).Row
For Each cl In Sheets("Certificate 1").Range("B13:B25" & intLastRow).Cells
'Ensure cell value is date
If IsDate(cl.Value) Then
'If date is today's date
'Note that Math.Round(<date>, 0 ) essentially removes the time
'+from any date value so #01/02/03 04:05:06# becomes #01/02/03#
If DatePart("m", cl.Value) = DatePart("m", Now()) Then
'Update column B's value
Sheets("Certificate 1").Range("H" & cl.Row).Value = intValue
End If
End If
Next
End If
End Sub
I have a list in Excel and I need to format rows based on the value in the cell 2 of that row. This is how data looks like
No. | Name | Other data | Other data 2 | Date | Date 2 |
For example, if Name=John Tery => color row as Red, if Name=Mary Jane => color row as Pink, etc.
I tried using conditional formatting, but I did not know how to make this work. I have very little experience with such tasks in Excel.
Can anyone help?
PS. all name are two-word names
if there are only a few names to handle, each conditional-format formula would look like this
=$B2="John Tery"
you need to have selected the affected rows from the top row down (so current active cell is in the 2nd row, not in the last row)
absolute reference to column $B means that for all cells in different columns, column B will be tested
relative reference to row 2 means that for cell in different rows, its own row will be tested (e.g. for cell A42, the formula will test value of $B42)
equality operator = will return either TRUE or FALSE (or an error if any of the arguments are errors) and it has the same use as inside IF conditions...
Edit Rereading the question, I saw that the entire row is to be coloured not just the name. I also decided that if a recognised name is replaced by an unrecognised name, the colour should be removed from the row. The original code has been replaced to address these issues.
I decided I did not care about the answers to my questions because the solution below seems the easiest for any scenerio I could identify.
First you need some method of identifying that "John Tery" is to be coloured red and "Mary Jane" is to be coloured pink. I decided the easiest approach was to have a worksheet NameColour which listed the names coloured as required. So the routine knows "John Tery" is to be red because it is red in this list. I have added a few more names to your list. The routine does not care how many words are in a name.
The code below must go in ThisWorkbook. This routine is triggered whenever a cell is changed. The variables MonitorColNum and MonitorSheetName tell the routine which sheet and column to monitor. Any other cell changes are ignored. If it finds a match, it copies the standard form of the name from NameColour (delete this statement from the code if not required) and colours the cell as required. If it does not find a match, it adds the name to NameColour for later specification of its colour.
Hope this helps.
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Changed As Range)
Dim CellCrnt As Variant
Dim ColLast As Long
Dim Found As Boolean
Dim MonitorColNum As Long
Dim MonitorSheetName As String
Dim RowNCCrnt As Long
MonitorSheetName = "Sheet2"
MonitorColNum = 2
' So changes to monitored cells do not trigger this routine
Application.EnableEvents = False
If Sh.Name = MonitorSheetName Then
' Use last value in heading row to determine range to colour
ColLast = Sh.Cells(1, Columns.Count).End(xlToLeft).Column
For Each CellCrnt In Changed
If CellCrnt.Column = MonitorColNum Then
With Worksheets("NameColour")
RowNCCrnt = 1
Found = False
Do While .Cells(RowNCCrnt, 1).Value <> ""
If LCase(.Cells(RowNCCrnt, 1).Value) = LCase(CellCrnt.Value) Then
' Ensure standard case
CellCrnt.Value = .Cells(RowNCCrnt, 1).Value
' Set required colour to name
'CellCrnt.Interior.Color = .Cells(RowNCCrnt, 1).Interior.Color
' Set required colour to row
Sh.Range(Sh.Cells(CellCrnt.Row, 1), _
Sh.Cells(CellCrnt.Row, ColLast)).Interior.Color = _
.Cells(RowNCCrnt, 1).Interior.Color
Found = True
Exit Do
End If
RowNCCrnt = RowNCCrnt + 1
Loop
If Not Found Then
' Name not found. Add to list so its colour can be specified later
.Cells(RowNCCrnt, 1).Value = CellCrnt.Value
' Clear any existing colour
Sh.Range(Sh.Cells(CellCrnt.Row, 1), _
Sh.Cells(CellCrnt.Row, ColLast)).Interior.ColorIndex = xlNone
End If
End With
End If
Next
End If
Application.EnableEvents = True
End Sub