I'm trying to make a prediction of income, at the moment I have a basic spreadsheet. there are 2 variables that change constantly and whenever I change them the whole spreadsheet changes and I don't want the past days to change.
My spreadsheet:
Date 24oct 25oct 26oct
income 300 250 500
income is x*y
variables x and y
if I change any of the variables it changes the whole days and I don't that to happen, today is 25oct it should change this day and 26oct and not 24oct.
This is a simple example ofcourse the real spreadsheet is not like this but I think it's enough to see what I'm looking for.
From what I can gather, you want to store the values of the income associated with any time before (and including) today. This can be accomplished by copying the values into the cells, and protecting them from edits.
The following code checks the range of dates for anything less than or equal to today. If it is either today or a previous day, it copies only values of the date and the income, and protects the cells from edits.
Sub UpdateProtection()
'Declare the range of dates
Dim Rng As Range
Set Rng = Range("A1:A4") 'Or whatever your range of dates is
'Set the time as the current time
MyTime = Date
'Loop through each cell in the range of dates
For Each Cell In Rng
'If the date in the cell is less or equal to now, lock the cells
If Cell.Value <= MyTime Then
Cell.Formula = Cell.Text 'Copy the Date
Cell.Locked = True 'Lock the Cell
'Copy the value of the "Income"
Cell.Offset(1, 0).Formula = Cell.Offset(1, 0).Value
'Lock the associated income
Cell.Offset(1, 0).Locked = True
Else
'Unlock the date if it's after today
Cell.Locked = False
'Unlock the associated "Income"
Cell.Offset(1, 0).Locked = False
End If
Next Cell
'Protect the sheet
Sheets("MySheetName").Protect
End Sub
This assumes that the incomes are just below the dates. You could call this sub from a Worksheet_Change event, if you wanted it to update the protection every time the sheet was updated.
If I've misunderstood the question, or missed anything let me know.
Related
I need to lookup a specific cell in another worksheet that has today's date as value, and edit the value of its adjacent cell by +1.
I am attempting to create a 'Points Tracker' for my studies. I will award myself one point for every task I complete. I have a workbook with two worksheets ('Sheet1' and 'data').
On the 'Sheet1' worksheet, I will have a visual look of my progress with a dynamic heatmap ranging from the past 27 weeks. Also a button at the top, which I intend to press every time I finish a task to add one point to my daily tally.
On the 'data' worksheet, I have a simple table with two columns (columnA will be the date ranging from 2022 to 2026 & columnB the points for each day.
I linked the values in the columnB of the data's table to the dynamic heatmap in Sheet1, which means, when the points in columnB are edited, I will see them live in the heatmap.
Now, I need to add points to today's date in the data's table. Like what Vlookup does, but instead of returning the value in the range's column2, I want to edit it by 1.
This appears to be very similar to what I want.
I tried the following, which results in an error:
Private Sub Worksheet_Change()
Dim temp As Range
If Not Intersect(Target, Range("E3")) Is Nothing Then
Set temp = Range("data!A:A").Find(Trim(Range("E3")), LookIn:=xlValues, lookat:=xlWhole)
If Not temp Is Nothing Then
Range("K3") = temp.Offset(0, 1)
temp.Offset(0, 2) = Range("Q3")
End If
End If
End Sub
Something else that I tried was to assign a specific cell in Sheet1 for today's points (Sheet1!$A$1), and then adding the following formula to the cells in columnB of the data table: =If(A1=TODAY(),Sheet1!$A$1,B1).
This way, if I were to add a simple +1 button to that (Sheet1!$A$1), the data table would populate accordingly. However, there's a circular reference in that formula that messes up my heatmap.
Personally, I would cut out the Intersect function as it's not really applicable and additionally change the event to Button1_Click since you only want it to run when the button is clicked anyways.
Sub Button1_Click()
Dim temp As Range
Set temp = Range("data!A:A").Find(What:=Format(Date, "d/m/yyyy"), LookIn:=xlValues, LookAt:=xlPart)
If Not temp Is Nothing Then
temp.Offset(0, 1).Value2 = temp.Offset(0, 1).Value2 + 1
End If
End Sub
You would also ideally put this in your workbook's ThisWorkbook project.
We currently have a spreadsheet that is used for scheduling, the gentleman using it doesn't want it changed so what I was thinking was create a new sheet with different formatting using VBA or a macro or?? I will then be able to import the new sheet into access where it is needed for a different program. I am attaching 2 different pictures the first is what it looks like now and 2nd is what I would like it to look like.
Old format
Better picture of Old Format
New format
. I have not done a lot of coding in Excel, normally just ='Sheet1'!E5, but didn't see how I could move the date properly and then not have the date show up any where else. The schedule may have 1 item assigned for a day or multiple items. If I have left something out that would be helpful please let me know.
If I understand you correctly...
The old format is something like this :
The expected result for the new format :
If that's what you mean...
Sub test()
Dim rg As Range: Dim cell As Range
Dim rgCnt As Range: Dim cnt As Long
Sheets("Sheet1").Copy Before:=Sheets(1)
With ActiveSheet
.Name = "TEST"
.Columns(1).Insert
.Range("A1").Value = "DATE"
Set rg = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
End With
For Each cell In rg.SpecialCells(xlCellTypeBlanks)
Set rgCnt = Range(cell.Offset(1, 0), cell.Offset(1, 0).End(xlDown))
If cell.Offset(2, 0).Value = "" Then cnt = 1 Else cnt = rgCnt.Rows.Count
cell.Offset(1, -2).Resize(cnt, 1).Value = cell.Offset(0, 1).Value
Next
rg.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
There is a consistent pattern in the old format, where to the right of each blank cell in column B is the date. So we use the blank cell in column B as the benchmark to get the date in column C.
The process:
it copy sheet1 where the old format is.
name the copied sheet to "TEST"
insert one column, and put the header name "DATE"
since HD-2 now is in column C (after insert one column)
so the code make a rg variable to data range in column C.
Then it loop to only the blank cell in rg
set the range to check how many data under each date into rgCnt variable
if the looped cell offset(2,0) is blank then there is only one data under the date so it make the value of cnt variable = 1
if the looped cell offset(2,0) is not blank then there is more than one data under the date, then have the value of cnt from the rgCnt rows count.
then it fill column A (DATE header) with the date as many rows defined by the cnt value.
After the loop done, it delete the entire row of all blank cell in rg variable.
I'm trying to loop through a data set in Excel where the deciding factors for each block of rows is based on the second column (WO#) because I want to perform calculations (not part of this question) just for items in the same grouping.
Visualization on iterating through blocks of rows
Sub test()
Dim totalHrs As Integer, lastRow As Integer
Dim block As Range, dataSet As Range
lastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Set dataSet = Range("A2:G" & lastRow)
For Each block In Columns("B").SpecialCells(xlCellTypeConstants, xlTextValues).Areas
'Do calculation stuff
Next block
End Sub
Right now I am having trouble defining what range 'block' should be since it will constantly change. A block begins when the "WO#" column is one number, and the block ends once that column's value changes to something else. How do I go about defining this range?
An easier way would be to just extract rows that have the same WO# into a new table and do the calculations there, but since this dataset can get quite large I would prefer not to do that as the macro will become way too heavy
What if you added this into G11 =IF(B11=B12,F12,C11) and then in F11 you added =G11-E11 and then dragged them down.
It should check to see if it's the last entry in the set and then set itself to the delivery date or set itself equal to the start day of the line below.
Edit:
Try replacing the F11 cell with this =WORKDAY(G11,-E11) and dragging down to account for workdays. To account for holidays, you can create a second sheet to list them out as dates and then add them as a range for the third, optional, argument in the Workday function. Please see the Workday documentation if more clarification is required on the function's use.
The code below defines blocks of similar values in a column. To use this code, either add a column to your worksheet combining columns B and C into one value (=B11&C11) or edit the code to check two columns (If rngCell.Offset(0, 0).Value = rngCell.Offset(1, 0).Value And rngCell.Offset(0, 1).Value = rngCell.Offset(1, 1).Value Then). Also, expand the blocks to more than one column.
'Starts the first block with the first cell in a column.
Set rngBlock = rngColumn.Cells(1)
'Checks every cell in a column.
For Each rngCell In rngColumn
'Checks whether a cell's value equals the cell below it.
If rngCell.Value = rngCell.Offset(1, 0).Value Then
Set rngBlock = Union(rngBlock, rngCell.Offset(1, 0))
'If equal, includes the cell below in the block.
Else
'If not equal, does something with the block...
Debug.Print rngBlock.Address
'Starts the next block with the cell below.
Set rngBlock = rngCell.Offset(1, 0)
End If
Next rngCell
I am working on a model that requires me to sort data in a range by date, before copying the data into a different template on another sheet. Every row has a formula that pulls data from Bloomberg, so even if the cell looks empty, excel recognizes that there is content in the cell. Sorting the date column as it is does not work, as excel wont recognize the data that Bloomberg pulls as a date, so it would be sorted from A to Z, which scrambles the dates instead.
To work around this, I inserted and adjacent column with the formula (using cell A1 as an example) "=(A1+0)" that then allows the column to be sorted from new to old. The problem here is that if cell A1 does not display a date (in other words, it appears empty yet the cell contains a formula that leaves the cell looking empty if no date is pulled) it returns a #VALUE! error and sorting new to old would put the errors at the top (Thank you Excel for this fantastic feature, btw).
To work around this new issue, I replaced the above formula in the cell with "=IFERROR(A1+0,1)" which gives me the date 1/1/1900. Fine, now the data is sorted in the manner I want it, but I have a bunch of ancient dates that just make my end product look ugly.
I have two questions, first; how can I use VBA to delete the data in the cells where the date equals 1 (which shows the date 1/1/1900), and only those cells? Or, alternatively, only copying the rows above the cell that contains 1/1/1900. This is a relatively small amount of cells that would be affected by this, 40 at most.
Second; is there a different way of sorting the data using VBA that I am missing, that might be more efficient?
Try this macro, I tried to test it with as many anomalies as possible.
Sub SortByDateColumnH()
Dim r As Range: Set r = Sheet1.Range("B3:P40")
Dim cel As Range
For Each cel In r.Columns(7).Cells
If IsError(cel.Value) Then
cel.Value = 0
ElseIf Not IsDate(cel.Value) Then
cel.Value = 0
Else
cel.Value = CLng(cel.Value)
End If
Next
r.Columns(7).NumberFormat = "0"
r.Sort Key1:=r.Cells(1, 7), Order1:=xlDescending, Header:=xlNo
For Each cel In r.Columns(7).Cells
If cel.Value < 100 Then cel.ClearContents
Next
r.Columns(7).NumberFormat = "m/d/yyyy" '<-- set the format to your preference
'r.Copy Destination:=someDestination ' you can copy the range by code if needed
End Sub
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