I have a large file that I am working on and need to be able to calculate people DOB. I have attached a sample file here to get an idea.... but basically what I am looking to do is ONLY if data exists in the "DOB" column, for "Age" to be calculated.
DOB will be listed in every other column for up to 18 different people (so column A, C, E.....) In columns B, D, F..... I am looking to have the age be calculated in years.
The catch is, there will NOT always be data for 18 people, so this is something that would only need to calculate IF data is present in the DOB column.
Ideally this would be a macro that I would run when I open the file so that all of the ages can update.
How do I even go about doing something like this?
I would expect output to just show age in years.... so if DOB was 01/01/2001 - age would show as 18
I'm going to make the assumption that VBA is overkill. This worked for me ...
=IF(A1="","",ROUNDDOWN(YEARFRAC(A1,NOW()),0))
If you were looking at a VBA solution, the above formula is translatable directly to VBA. It's not complete in relation to your context but that's a bigger piece that is hard to inject into without seeing your code at present ...
Public Sub WriteAgeToCell()
If Range("A1").Text <> "" Then
Range("A2") = WorksheetFunction.RoundDown(WorksheetFunction.YearFrac(Range("A1"), Now), 0)
End If
End Sub
Using Workbook_Open() in your Workbook object can be used to automatically recalculate what you need.
So to put it all together, and with a little bit of compromise, you can do the following ...
Private Sub Workbook_Open()
Dim objSheet As Worksheet, lngAgeCol As Long, lngEndRow As Long, i As Long
Dim lngStartRow As Long
With Range("rngHeaderAge")
Set objSheet = .Worksheet
lngAgeCol = .Column
lngStartRow = .Row + 1
End With
lngEndRow = objSheet.Cells.SpecialCells(xlLastCell).Row
For i = lngStartRow To lngEndRow
objSheet.Cells(i, lngAgeCol).FormulaR1C1 = "=IF(RC[-1]="""","""",ROUNDDOWN(YEARFRAC(RC[-1],NOW()),0))"
Next
End Sub
When the workbook is opened, it will fill down the formula from the row below the header column and then if DOB's are changed during the session, the age will update on the fly.
To make the above work, all you need to do is update the code into the Workbook object within the VBA editor and create a named range against the header for the age column, as shown below.
Related
My problem is how to populate the cmbSelProp ComboBox with propIDs from a workbook scoped Named Range called PropLocs. The columns of interest Column "A" which contains the list of propIDs and Column "K" which contains the ActiveStatus of each propID. I also have Named Ranges for both columns of interest, propIDs and actStatus respectively. The actStatus, Column "K", portion of the range are set to True/False when the properties are added and subsequently initialized and annual worksheets are automatically generated.
I only want cmbRptPrpID populated with propIDs having an actStatus = True.
I have spent many hours over the past few weeks going blind doing Web Searches, looking at links, and trying suggestions from the various links without success. I,m as "Lost as a blind man in a snow storm!"
There are broader issues associated with the problem I am dealing with and understanding how to solve, and understand, the issue at hand will help me in the future development of my application.
UPDATE
the 2 mentioned additional ranges are in columns "A" and "K"
Update 2
Business Logic
The application I am developing utilizes a multipage object and there are pairs of dynamic comboboxes, cmbSelProp and cmbYears for example, used to select the active worksheet and enter Monthly expenses, view/generate Reports, etc. cbmSelPropselects the property ID, and the cbmSplProp_Change() event configures cmbYears list values based on the variable wsStartYr in column "K" and wbCurYear which is the Current Calendar Year. the annual worksheets have a Worksheet TabName of propId_Year and are selected using a variable wsA = pID & "_" & wsYr. I do not want propIDs with an Inactive status to appear as a part of the cmbSelProp list values.
This is a link to My First Question here on StakOverflow which is related to this question.
I really need some help figuring this out!
Thanks in advance for your assistance.
here is the code I have been trying to work with.
selectedRow = cmbSelProp.ListIndex + 3
For Each cPart In wsCntrl.Range(Range("propIDs"), Range("A" & Rows.Count).End(xlUp))
pAct = wsCntrl.Cells(selectedRow, "K").Value
With Me.cmbSelProp
If pAct = "True" And cPart.Value <> "" Then cmbSelProp.AddItem cPart.Value
End With
Next cPart
There are a number of issues in your code. Rather than breaking down all the errors/issues, I'll show you how I would do it.
From your previous Q, I take it that your Combo Box is on a Userform.
I've created a Userform with a combo box and a button to load it. You can change how you call the load function to suit your needs.
The UserForm code
Option Explicit
Private Sub btnTest_Click()
Load_cmbSelProp
End Sub
Private Sub Load_cmbSelProp()
Dim propIDs As Range
Dim actStatus As Range
Dim rw As Long
Set propIDs = ThisWorkbook.Names("propIDs").RefersToRange
Set actStatus = ThisWorkbook.Names("actStatus").RefersToRange
Me.cmbSelProp.Clear
For rw = 1 To propIDs.Count
If propIDs.Cells(rw, 1).Value2 <> vbNullString Then
If actStatus.Cells(rw, 1).Value2 = True Then
Me.cmbSelProp.AddItem propIDs.Cells(rw, 1).Value2
End If
End If
Next
End Sub
The Named ranges
The result
Okay, so don't mind the title, I had trouble summarizing my current issue. But first here is what I am trying to do :
I have three sheets, first one is containing a list of Attributes, the second a list of Categories and the third a cross table associating Attributes and Categories.
The code i'm working on is quite straightforward : when selecting one or many attributes (or categories) using checkboxes and executing the macro, the code will look for ticked checkboxes, get the ID associated to the selected attributes (or categories), then delete the line in the attribute (or category) worksheet and also in the cross table.
The sheets looks like that :
*Attribute Sheet*
*Category Sheet*
*Cross Table*
And here is my code :
Sub Delete_Selection()
Dim Wb As Workbook: Set Wb = Workbooks("DataBase WIP.xlsm")
Dim Sws As Worksheet: Set Sws = ActiveSheet
Dim CrossWs As Worksheet: Set CrossWs = Sheet6
Dim Cb As CheckBox
Dim Checking As Range
Dim LastRow As Long: LastRow = Sws.Cells(Sws.Rows.Count, "B").End(xlUp).Row
Dim CRow As Long, IDColumn As Long, IDRow As Long
Dim CID As String
IDColumn = Sws.Cells.Find(What:="ID", LookAt:=xlWhole).Column 'Look for the ID column in the current sheet
MsgBox (IDColumn) 'Debug purpose
For Each Cb In Sws.Checkboxes
If (Cb.Value = 1) Then 'If checkbox is ticked, proceed
CRow = Range(Cb.LinkedCell).Row 'Get the row number of the checkbox
MsgBox (CRow) 'Debug purpose
CID = Cells(CRow, IDColumn).Value 'Get the ID value
Rows(CRow).Delete Shift:=xlUp 'Delete the row
Cb.Delete 'Delete the checkbox
If (ActiveSheet.CodeName = "Sheet2") Then 'If attributes are being deleted, proceed
MsgBox (CID) 'Debug Purpose
IDRow = CrossWs.Cells.Find(What:=CID, LookAt:=xlWhole).Row 'Find the corresponding row in the cross table
CrossWs.Rows(IDRow).Delete Shift:=xlUp 'Delete it
End If
If (ActiveSheet.CodeName = "Sheet5") Then 'If categories are being deleted, proceed
MsgBox (CID) 'Debug Purpose
IDColumn = CrossWs.Cells.Find(What:=CID, LookAt:=xlWhole).Column 'Find the corresponding column in the cross table
CrossWs.Columns(IDColumn).Delete Shift:=xlToLeft 'Delete it
End If
End If
Next
End Sub
The issue :
The code works perfectly fine when selecting and deleting multiple attributes
The code works when selecting and deleting one category
BUT : when selecting multiple categories and running the deletion code, it deletes them all in the category sheet but it only delete one corresponding column in the cross table.
Example : if I want to delete the beef and beans category, I select them using the checkboxes then press the button, in the category sheet they're all successfully deleted (yay !) but only the beef column will be deleted in the crosstable.
So to figure out why, I decided to print the relevant variables, what is happening in the previous example is the following :
IDColumn = 1 which is normal
CRow = 10 fine too
CID = DOC9 expected
Then
IDColumn = 1 Wasn't supposed to change
Crow = 10 The rows have been shifted up to fill the gap so totally normal
CID = "" And that's where my issue is.
Despite looking at the right cell, CID don't get the value contained in it and I don't understand why at all.
Important precision, the attribute sheet is perfectly normal while the category sheet contains a Table ! I think that's where the issue lies but I couldn't find anything useful on the Internet.
And I don't understand why the program would be able the read the value of a cell the first time and then doesn't. I may have missed something obvious so I apologize if its the case but any help would be greatly appreciated !
Edit 1 : It has nothing to do with the Categories being in a table, I wrote a similar code but I ran into the exact same issue even without looking at a Table. I still don't know what's happening.
I found a workaround by first reading all my ID's and storing them into an array and then looping through my array to modify my cross table. I will probably do the same for my current issue.
Okay, I found the problem.
Once again I wasted a lot of time because of a stupid mistake.
When I was deleting a category, I needed to find the column linked to that category in my cross table, and I stupidly used the same variable referring to the ID column of my Category sheet (i.e. "IDColumn"), changing its value and therefore when reading the next ID, my code was looking in the wrong cell.
Thanks to anyone who have tried to help me ! I will hopefully not make a fool of myself next time ahah.
I have a small tracker program I am building in Excel VBA. I have a userform that I keep up throughout the day, inputting my tasks/data via an 'Add' button. At the end of the day, I click the 'Post' button, and it saves the data to my worksheets where appropriate.
Thought I had it finished and working correctly, but now apparently my sub to select the correct column based on the day's date is not working, and I'm not sure why, as it had been working perfectly throughout development.
This piece is vital, as my other functions to post the day's data rely on this. I've read a lot of other posts about how to do this (selecting a column based on current date), but none have explained why mine isn't working. Trying to become a better coder, and not just a copy/paste coder, so thought I would try asking here. Copy/Paste usually gets me into these messes, where I'm using tools/functions that work, but I don't know why, and can't troubleshoot/debug on my own.
My total project involves 5 worksheets, but this sub should only involve 2 of them. "Tasks" and "Data Tracker", both of which have a row of dates.
Below is the sub in question.
Public Sub currentDate()
'sub to assign current date to global values
Set rng - Range("H2:HZ2")
Set myDate = rng.Find(What:=Int(Date), LookIn:=xlFormulas)
End Sub
If I step through it, Date is pulling the correct date, and xlFormulas shows a value of -4123 (I don't even know if that matters)..
(UPDATE) so apparently, this morning, it decided to work perfectly. facepalm Any clues?
(UPDATE) so, per usual, I try adding features as I fix something else, so this took a bit more researching to solve, but #Super-Symmetry pointed me in the right direction! As noted in a comment down below, I changed my date headers in the two sheets to be more of a "start date + n" situation. Although his suggestion of using xlValue instead of xlFormula was on the right track, Find. was still having trouble with date vs serial. Ultimately this is what I got to work:
Public Sub currentDate()
'sub to assign current date to global values
'load the date range
Set rng = Worksheets("Tasks").Range("H2:HZ2")
'load the values in the range
dateArray = Range("H2:HZ2").Value
Dim day As Variant 'object to load dateArray
Dim loc As Integer 'matches date with cell location
'converting the date to serial
For Each day In dateArray
day = CLng(day)
loc = loc + 1
If day = Date Then 'we found the right column
Set myDate = rng(loc)
'selects the correct cell
If ActiveSheet.name = "Data Tracker" Then 'adjust the row
Cells(myDate.Row + 3, myDate.Column).Select
Else 'sheet must be Tasks
Cells(myDate.Row + 2, myDate.Column).Select
End If
Exit Sub
End If
Next
End Sub
It's not elegant, but it works.. please feel free to educate me if you have any cleaner ways to do this!
Try changing Int(Date) to CLng(Date)
Public Sub currentDate()
'sub to assign current date to global values
Dim rng As Range, myDate As Range
Set rng = Range("H2:HZ2")
Set myDate = rng.Find(What:=CLng(Date), LookIn:=xlValues)
End Sub
So, right now I have this excel sheet where there is a last revision date. I have named this column "LastRevisionDate". And then I have a column named "RevisionFrequency" . The "RevisionFrequency" contains a drop-down menu consisting of terms, "Annually", "Bi-Annually"(2 times in a year), "Semi-Annually", and "Quarterly". And then I have a column where it states the "NextRevisionDate". So I want to create a VBA code that would calculate the NextRevisionDate from the LastRevisionDate and the RevisionFrequency.
For example. Say in column "A" i have the RevisionFrequency to be "Bi-annually" And the last revision date was Mar-14 in column "B", then I would want the NextRevisionDate in column "C" to state Mar,Sep .Thats basically saying that the item gets revised twice a year. So I would want to create a macro where Column "C" is based off the RevisionFrequency and LastRevisionDate. I realize I could do this with a formula, but I have new items being added constantly so I do not want to keep copying formulas into each cell. Also for some items, they do not need revision, I would also like to have a blank cell if there is no LastRevisionDate.
So far, I have this updated code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Sheets(1)
If Not Intersect(Target, ws.Range("LastCalDate").Value) Is Nothing Then
Dim Lastdate As Date
Dim DueDate As Variant
Dim Frequency As String
Dim R As Variant
Dim C As Variant
Dim R1 As Variant
Dim C1 As Variant
Dim R2 As Variant
Dim C2 As Variant
R = Range("LastCalDate").Row
C = Range("LastCalDate").Column
R1 = Range("CalDueDate").Row
C1 = Range("CalDueDate").Column
R2 = Range("CalFrequency").Row
C2 = Range("CalFrequency").Column
Lastdate = Cells(R, C).Value 'Last Cal Date
DueDate = Cells(R1, C1).Value 'Cal Due Date
Frequency = Cells(R2, C2)
If Frequency = "Annually" Then
DueDate = DateAdd("mmm", 12, Lastdate)
End If
If Frequency = "Semi-Annually" Then
DueDate = DateAdd("mmm", 6, Lastdate)
End If
If Frequency = "Quarterly" Then
DueDate = DateAdd("mmm", 3, Lastdate)
End If
End Sub
“Am I just overcomplicating my code?”
That is the wrong question. The first question is not “What can I do?” but “What do my users want?”
If you start by saying “I can produce wooden clogs”, you may never learn they want soft slippers. You may not be able to produce soft slippers but you can probably produce something a lot better than wooden clogs if know it is required. Start with the design of the ideal product then cut it down to what is practical.
From your description, I visualise something like this:
You may have many other columns and these three columns may be in different positions; it does not matter, we will restrict ourselves these columns for now.
It sounds to me as though you have two requirements and an issue:
You have a worksheet where the values in the Next Revision Date column may be unreliable or missing. You require a macro that will run down the existing worksheet and enter correct values into the Next Revision Date column.
You have a requirement to set the values in the Next Revision Date column automatically as new rows are added of existing Revision Frequencies and Last Revision Dates are amended. This could be achieved by running macro 1 or using the Worksheet Change event, as you suggest. There may be other approaches but I will not address this requirement.
If you look at the last three rows of my example worksheet, you will notice the day of the month in the Next Revision Date column is not the same as that in the Last Revision Date. This is because I converted the value in the Frequency column to 3, 6 or 12 and added that number of months to the Last Revision Date. In the last three rows the new month does not have as many days as the old and the VBA function has, for example, converted 30 February to 2 March. Is this the effect you require? I have included code to bring the date back to the “correct” month. Often the most difficult task in macro design is identifying all these exceptions and specifying how they are to be handled.
I will only consider macro 1 first since you can use it for both requirements while you are design and implementing macro 2. If you run into problems with macro 2, ask a new question. You can ask as many questions as you like – providing they are good questions – but they should only be one issue per question.
You need a macro that will step down every row of the worksheet. If you are using an online tutorial or you have bought a book on Excel VBA, you may find a suitable example there. If you are using neither an online tutorial nor a book, please start. It will not take long to master the basics of Excel VBA and the time spent learning the basics will quickly repay itself. Trying to search the web for code when you do not know the basics is very difficult.
If your tutorial/book does not tell you how to step down every row of the worksheet, try searching SO for “[excel-vba] find last row of worksheet”. There are lots of variations of this question so you should have no difficulty in finding something suitable. You do not have to do so on this occasion because I show you how below but I believe this is the best way of using this site. Break your requirement down into little steps and then search for a question relevant to each step.
Below is a simple macro 1. Study my code and come back with questions if necessary. However, the more you can understand on your own, the faster you will develop.
Welcome to the joys of programming.
Option Explicit
' Using constants for values that may change makes your code easier to
' understand and easier to maintain.
Const ColFrequency As Long = 1
Const ColLastRevisionDate As Long = 2
Const ColNextRevisionDate As Long = 3
Const RowDataFirst As Long = 2
Sub FixNextRevisionDate()
Dim DateLastCrnt As Date
Dim DateNextCrnt As Date
Dim NumMonthsToStep As Long
Dim RowCrnt As Long
Dim RowLast As Long
' Replace "Data" with the name of your worksheet
With Worksheets("Data")
' This is the most popular method of finding the last row but it will
' not work in every situation. I believe it is appropriate for your
' current requirement but suggest you look for questions that describe
' other methods and which explain why they might be better.
RowLast = .Cells(Rows.Count, ColFrequency).End(xlUp).Row
For RowCrnt = RowDataFirst To RowLast
' Convert Frequency to 3, 6 or 12
' I have used the LCase function to allow for inconsistent use of
' upper and lower case
Select Case LCase(.Cells(RowCrnt, ColFrequency).Value)
Case "annually"
NumMonthsToStep = 12
Case "bi-annually"
NumMonthsToStep = 6
Case "semi-annually"
NumMonthsToStep = 6
Case "quarterly"
NumMonthsToStep = 3
Case Else
' Unknown frequency. never assume the worksheet is correct
' if an error will cause your macro to fail.
' This is an easy way to highlight faulty values for user
' attention.
With .Cells(RowCrnt, ColFrequency)
.Interior.Color = RGB(255, 0, 0)
NumMonthsToStep = 0
End With
End Select
If NumMonthsToStep <> 0 Then
' Had valid frequency
If IsDate(.Cells(RowCrnt, ColLastRevisionDate).Value) Then
' Value in Last Revision Date column is a date
DateLastCrnt = .Cells(RowCrnt, ColLastRevisionDate).Value
' Calculate next date by adding NumMonthsToStep
DateNextCrnt = DateSerial(Year(DateLastCrnt), _
Month(DateLastCrnt) + NumMonthsToStep, _
Day(DateLastCrnt))
' You may not want this but it shows how to do it if you do
If Day(DateNextCrnt) < Day(DateLastCrnt) Then
DateNextCrnt = DateSerial(Year(DateNextCrnt), _
Month(DateNextCrnt), _
0)
End If
With .Cells(RowCrnt, ColNextRevisionDate)
.Value = DateNextCrnt
' Replace with date format of your choice
.NumberFormat = "d mmm yy"
End With
Else
' The Last Revision Date is not a date
With .Cells(RowCrnt, ColLastRevisionDate)
.Interior.Color = RGB(255, 0, 0)
End With
End If
End If
Next
End With
End Sub
I must be having a brain fog at this point because I am certain this is easy to do, and in fact I have managed to create other functions that are a bit more complicated for this project.
Anyway, what I am trying to do. I have a sheet (inventory-data) and in column 1, it lists a company name, which is a same for all the rows. i.e. each of the 1900 or so rows have companyname in the first cell.
Now, while the data will always be the same at each application, the number of rows will change.
So, I need a function that will first determine what the last row of data is in the range, and then change all of the cells in column one of each record to name_company. The company names will always be the same so I can staticly assign them. Here is what I have that does not work.
I was able to get it to work another way, but it would replace text all the way down to the very last row of the worksheet, way beyond where the data stops.
Thanks!
Sub changeCompany() 'Changes company name as pulled from Agemni into proper ETA format
Dim myCell As Range
Dim RngToChange As Range 'The range of cells that need to be changed
Dim LastRow As Long 'Declare variable to help determine the last row on a variable length worksheet
Dim i As Integer
With Worksheets("inventory-data") 'set the range to change
Set RngToChange = .Columns(1)
End With
LastRow = Worksheets("inventory-data").UsedRange.Rows.Count 'Have Excel determine what the last row is.
For i = LastRow To 1 Step -1
RngToChange.Cells.Value = "name_company"
Next i
End Sub
I've always had more success with [SomeCellOrRange].CurrentRegion.Rows.Count e.g:
Range("A1").CurrentRegion.Rows.Count
UsedRange looks for any use of cells, not limited to a continuous tabular block. It also sometimes needs you to re-save the workbook before it will properly shrink after you have eliminated some rows.