I am a newbie to using VBA to program functions in Excel (just started this morning actually). Here is my problem including my almost but non-working solution.
Problem outline:
I have 2 columns of data, a userID and a Date column. I want to create a function that returns the maximum date (latest) for a userID. A userID may appear once, or many times (number varies from user to user, but doesn't exceed 20).
Now to make this problem a easier for my little brain, I pre-sort the userIDs to appear one after another, and then created a third column to mark the first instance of a userID (not necessarily the one with the earliest/latest date) using a simple excel If statement: If its the first instance it is the userID, else it is empty.
Then I created a function that takes in a range of cells (userIDs), and a single other value (the third column cell containing a single value of userID)
A typical excel worksheet will look like this:
userID Date First Instance
1 3/3/12 1
1 3/2/11
1 2/3/14
2 2
2 3/4/15
2
2 5/6/15
3 5/5/16 3
4 4/4/14 4
4
4 6/7/08
...
I wrote the function below, which takes in userID as the iRange (I select more than 20 so that for other users which may have 20 instances of userID are also included), and idCell as the single identifier of the first instance of userId.
The logic behind the code is:
Loop through iRange and compare it to idCell
If it's equal, check that the next cell (next to the element from iRange is a date) and if it is
Check whether it is larger than the maxDate, store it if true
At the end I return maxDate
The result:
I get a number back, but it isn't a date and I don't think it has any bearing on a date.
Function returnDate2(iRange As Range, idCell As Range) As Date
Dim elem As Variant
Dim i As Long
Dim maxDate As Date
For Each elem In iRange
If elem = idCell Then
If IsDate(elem.Offset(0, 1)) Then
If elem.Offset(0, 1) > maxDate Then
maxDate = DateValue(elem.Offset(0, 1))
End If
returnDate2 = maxDate
End If
End If
Next elem
End Function
Thanks in advance!
Related
I have 2 columns in excel, A and B. In A I have percentages (rates) and in B integers numbers (years).
rating PD year
0.39% 3
0.88% 2
1.32% 17
0.88% 1
0.26% 15
0.17% 2
0.17% 2
0.59% 2
0.59% 2
Then I have a Table in which in column F I have years and in row I have text.
Like this (the table is much bigger and years go up to 30):
Rating
Year AAA AA+ AA AA-
1 0.003% 0.008% 0.018% 0.049%
2 0.016% 0.037% 0.074% 0.140%
3 0.041% 0.091% 0.172% 0.277%
4 0.085% 0.176% 0.318% 0.465%
5 0.150% 0.296% 0.514% 0.708%
And so on (the table is much bigger than this).
So I would need a function, or a shortcut, which, for a given rate in column A and a given year in column B, gives me, in column C, the corresponding rating (AAA,AA+,AA etc.).
In the table the rates are the maximum. So if I have A1=0.50% and B1=2, then I go to look at the table, year 2 and corresponding rate, which is 0.74% (and therefore AA), because AA+ is 0.37% and is too low.
In other words, AA+ and year 2 are all the rates between 0.16% and 0.37%. And AA with year 2 are all the rates between 0.37% and 0.74%.
Do you know how I could perform this task?
Thank you very much.
For the sake of code readability, I've used two custom-made functions, alongside the main procedure shown here. Otherwise it would be a huge code-dump.
Before you begin, you have to change/check these data fields.
The (blue) data table needs to be named "scores" (or changed inside code to your own name)
Same goes for the (green) grades table - to be named "grades" and start in F1
Last but not least, the code presumes these two tables are in a sheet called "Sheet1"
So all of this needs to be changed within the code, if the names do
not match!
Now to the procedure:
Option Explicit
Private Sub run_through_scores()
Dim scores As ListObject ' table from A1
Dim grades As ListObject ' table from F1
Set scores = Sheets("Sheet1").ListObjects("scores")
Set grades = Sheets("Sheet1").ListObjects("grades")
Dim cell As Range ' for "for" loop
Dim inrow As Long ' will store in which row the year is
Dim resultColumn As Integer ' will store in which column the percentage is
'for every cell in second column of scores table (except header)
For Each cell In scores.ListColumns(2).DataBodyRange
inrow = get_year(cell).Row - 1
' ^ returns Row where result was found, -1 to accoutn for header
'using our get_interval() function, _
determines in which column is the sought percentage
resultColumn = get_interval(cell.Offset(0, -1), inrow).Column
cell.Offset(0, 1) = Sheets("Sheet1").Cells(1, resultColumn)
'write result in Column C ^
Next cell
End Sub
And to the functions:
get_year()
returns a Range Object from the "grades" table, in which we found
the matching year from our "scores" table. If the desired year is not found, it returns the year closest to it (the last table row)
' Returns a Range (coordinates) for where to search in second table
Private Function get_year(ByVal year As Variant) As Range
Dim grades As ListObject ' table from F1
Set grades = Sheets("Sheet1").ListObjects("grades")
Dim testcell As Range
Set testcell = grades.ListColumns(1).DataBodyRange.Find(year, LookIn:=xlValues)
'if found
If Not testcell Is Nothing Then
Set get_year = testcell
Else
Dim tbl_last_row As Long 'if year not found, return last row
tbl_last_row = grades.ListColumns(1).DataBodyRange.Rows.Count
Set get_year = grades.ListColumns(1).Range(tbl_last_row)
End If
End Function
And the second function:
get_interval()
returns a Range Object from the "grades" table. It compares individual cell ranges and returns upon a) if the sought percent from "scores" is less or equal (<=) then current cell percent or b) if we went through all the cells, it returns the last cell
(because it must be higher, than the maximum of specified interval)
Private Function get_interval(ByVal what As Variant, ByVal inyear As Long) As Range
Dim grades As ListObject ' table from F1
Set grades = Sheets("Sheet1").ListObjects("grades")
Dim cell As Range
For Each cell In grades.ListRows(inyear).Range
'check for interval
If what <= cell And cell.Column <> 6 Then 'we don't want to check year column
Set get_interval = cell
Exit Function
End If
Next cell
' if we arrived here, at this stage the result will always be the last cell
Set get_interval = grades.ListRows(inyear).Range(, grades.ListColumns.Count)
End Function
Upon firing (invoking) the run_through_scores() procedure, we get the results as expected:
if you have any questions, please let me know :)
I have a dynamic table range of certain values (amounts). These amounts are generated into the table through a macro I've created.
What I want to do: Rank these amounts into the empty column by number.
eg. the cell in Column G next to 89k would be ranked as 1, one next to 77k would be 2 etc.
I also already have other functions defined, which I'm not going to explain here for readability reasons, but all you need to know: there are two variables obtained through functions
tbl_first = (int) Index of the ListRow of the first table item (so in this case it would be the row with 89k = 1st row so in this example 1)
tbl_last = (int) same as above, but indexes the last row (77k) in this example as 7
so my code is the following
' sets the tbl variable to the red table in the picture
Dim tbl As ListObject: Set tbl = Sheets("Summary").ListObjects("time_top")
Dim pos As Integer, diff as integer
diff = tbl_last - tbl_first
For j = tbl_first To tbl_last ' loops through all the added rows
For n = 1 to diff' indexing for the large function
' index the pos through the excel large function for our values (should return the k-th position from the largest value)
pos = Application.WorksheetFunction.Large(Range(Cells(tbl_first, 6), Cells(tbl_last, 6)), n)
With tbl.ListRows(1)
.Range(j, 6) = pos ' add the value to the column G to the right
End With
Next n
Next j
So the expected result would look like this:
I also keep getting the following error, which is caused by me incorrectly assigning the pos value.
Either way, probably multiple of things wrong here and much more elegant solution is out there, that just didn't hit me yet.
Think you need Rank (watch out for equal ranks). Large returns the nth largest value of a set.
Here is a simple example on a two column table which perhaps you can adapt. The rank is added in the second column.
Sub xx()
Dim tbl As ListObject: Set tbl = Sheets("Summary").ListObjects("time_top")
Dim r As Range
For Each r In tbl.ListColumns(1).DataBodyRange
r.Offset(, 1) = WorksheetFunction.Rank(r, tbl.ListColumns(1).DataBodyRange)
Next r
End Sub
Struggling with an excel user defined function to calculate a total production generated by different bacteria patches starting at different times but following the same growth pattern; I have tried to simplify my problem below:
Example tables
PROFILE table: I have a 2 columns x 6 rows Table (A2:B9) showing a bacteria production per week depending on the age of the colony (column A gives the period, column B the production: in the first 3 weeks the bacteria produce 1/week in the next 3 weeks they produce 2 per week etc); I call this table my production PROFILE, this may vary depending on the type of bacteria I have (and other environmental parameters). I have decided in this particular example, and to keep it simple to show the population growth per period in a table, the growth values could of course be generated by a function (linear, exponential, with a decay factor etc) I guess that if I can crack the problem, adding a level of complexity with a growth function shouldn't be an issue.
RESULT table: I then have a 3 columns 20 rows table (A14:C33) which shows over a 20 week period (my 20 rows, numbered 1 to 20 in column A) when I start some bacteria cultures (1 in week 3, 2 in week 6 etc), I call it my RESULT table
I'd like to show in column C of the RESULT the total production of the colonies for each week.
I tried creating a PROD(week, PROFILE) function where I defined both "week" and "PROFILE" as variants and where "PROFILE" actually relates to my PROFILE table. It works fine when "week" is an individual cells (ie PROD(A18,PROFILE)=2) but doesn't work with ranges (PROD(A14:A33,PROFILE) returns an error message)
Function PROD(period As Variant, profile As Variant) As Variant
r = profile.Rows.Count
If profile(1, 1) >= period Then
PROD = profile(1, 2)
Else
For i = 2 To r
If profile(i, 1) >= period Then
If profile(i - 1, 1) < period Then
PROD = profile(i, 2)
End If
End If
Next i
End If
PROD = Application.Round(PROD, 2)
End Function
is there an elegant solution to populate column C of RESULT?
I did a similar thing on a previous assignment (finance) combining a sumproduct with the excel pmt function ( -pmt(rate, nper, pv,..) where pv was a range) and this did work, I managed to get a nice calculation of my total depreciation cost on a given period when I could have had items purchased in different quantities and at variable prices over the previous periods. the formula I used back then, shown on the attached Example of DepTable&Formula is
SUMPRODUCT(-PMT($C$7,$C6,$C$3:$V$3),N($C$4:$V$4<=C$2),N(($C$4:$V$4+$C6)>C$2))
I tried to replicate it here with a custom function with my bacteria population but I am really stuck.
I can't quite imagine what your profile table might look like nor, in fact, what exactly you want to extract. Perhaps my attempt below gives you some ideas. Please study it and let me know where it needs improvement.
Function PROD(period As Variant, profile As Variant) As Variant
Dim Fun As Variant
Dim R As Long
R = 1 ' should this always be 1?
Do
Fun = Fun + profile(R, 2).Value
R = R + 1
If R > profile.Rows.Count Then Exit Do
Loop While profile(R, 1) >= period
PROD = Application.Round(Fun, 2)
End Function
I wouldn't use this as a UDF, however. Instead, I would modify it slightly to write directly into the C column. Let the function be called from the Worksheet_Change event, linked to the profile table, or perhaps both tables, so that the data update automatically whenever there is a change. With the UDF updating will take place only when the sheet is recalculated, and I found that not to be easily controlled.
If this isn't what you want then it should be a lot nearer to it than what I did this morning. Take a look.
Function PROD(Period As Range) As Single
Dim Fun As Single
Dim Periods As Integer
Dim Weeks As Integer
Dim A As Integer
Dim R As Long
Periods = Period.Cells.Count
For A = 1 To Periods
Weeks = CInt(Period.Cells(A).Value)
With Range("Profile")
For R = 1 To (.Rows.Count - 1)
If .Cells(R, 1).Value >= Weeks Then Exit For
Next R
Fun = Fun + .Cells(R, 2).Value
End With
Next A
PROD = Application.Round(Fun / Periods, 2)
End Function
Call this function with =Prod(A14:A20) or =Prod(A14:A14) or = Prod(A14)
It will extract one result from the Profile table for each of the specified weeks. A14:A20 will have 7 results, and so would A16:A22. The function draws an average. So, with 7 results, these seven are added up and divided by 7. Perhaps this isn't yet what you want, but you might be able to manipulate the result of the function to meet your requirements.
I have an excel range I'm using as a database. The first column is sorted in ascending order by date, but there can be multiple records with the same date, e.g.
A B
1 15-Apr-2015 Carrot
2 15-Apr-2015 Yamagobo
3 16-Apr-2015 Turnip
4 17-Apr-2015 Parsnip
5 17-Apr-2015 Rutabaga
6 17-Apr-2015 Radish
7 18-Apr-2015 Daikon
(The stuff in column A are formatted dates, not text strings.)
What I'd like to get is the first record that has a date greater than or equal to the one I'm searching for, so I have:
Dim searchDate As Date
searchDate = CDate("4/17/15")
Dim searchRange As Range
Set dbRange = Worksheets("My DB").UsedRange
Dim v As Variant
v = Application.Match(CLng(searchDate), dbRange.columns(1), 1)
I expect v to now contain the index of the first row with 17-Apr-2015 in column A, 4. Instead, it seems to be returning the last row with 17-Apr-2015, 6.
Two questions:
1) Is there a way to use Match() (or any other function) to point at the first entry that matches, instead of the last?
2) Match() freaks out if I give it a Date type as its match parameter (hence the CLng() conversion). Is this to be expected, or am I doing something stupid?
Thanks.
Try to use Find instead of Match
To get the cell:
set MyRange = dbRange.Columns(1).Find(searchDate)
To get just the row:
MyRow= dbRange.Columns(1).Find(searchDate).row
I'm working on a timetabling piece of code. I am using a system of university modules and events associated to those modules, ie
Module CSC3039
Event1 - Lecture
Event2 - Lecture
Event3 - Practial etc
I need to check the times of each event in the module against each other and compare for clashes. The clashes do not need to be rectified, just highlighted. The table I will use is Events containing Event_ID (PK), Module_code (FK), Start_Date_Time, End_Date_Time plus other fields that don't matter here. I have figured out that I need to implement a For Each statement, ultimately resulting in an if statement such as:
if (startTime1 <= endTime2 or endTime1 >= startTime2) CLASH
My problem is trying to figure out the actual for loop here. I don't know what to write to declare my start times and end times. I presume it is a case of taking event1 and getting its start and end and then checking if event 2, 3 or 4 fit the above if statement. I'm trying to get this but could really use some guidance.
EDIT... Based on suggestions below I have implemented the following code:
'return all relevant tables from the Modules database, based on the module code entered by the user.
Dim eventTime = (From mods In db.Modules
Join evnt In db.Events On mods.Module_code Equals evnt.Module_code
Join rm In db.Rooms On rm.Room_ID Equals evnt.Room_ID
Join build In db.Buildings On build.Building_code Equals rm.Building_code
Where ((mods.Module_code = initialModCode) And (evnt.Room_ID = rm.Room_ID))
Select evnt.Event_ID, evnt.Module_code, evnt.Event_type, evnt.Start_Date_Time, evnt.End_Date_Time, build.Building_code, rm.Room_Number)
'use the gridview to display the result returned by the above query
gdvEventsTable.DataSource = eventTime
gdvEventsTable.DataBind()
Dim listClashes As New List(Of Array)
For i As Integer = 0 To eventTime.Count - 1
For j As Integer = i + 1 To eventTime.Count - 1
If (eventTime.ToList(i).Start_Date_Time < eventTime.ToList(j).End_Date_Time) And (eventTime.ToList(i).End_Date_Time > eventTime.ToList(j).Start_Date_Time) Then
MsgBox("Clash", MsgBoxStyle.MsgBoxSetForeground, "")
listClashes.Add(eventTime)
Else
MsgBox("No Clash", MsgBoxStyle.MsgBoxSetForeground, "")
End If
Next
Next
When trying to add an event to my array list I have noticed, in debug, that no events are sent to the list.
If you want to compare all the pairs of events that are in an array or some kind of a collection, you can use a loop like:
Dim ModuleEventArray() As ModuleEvent
'...
For i As Integer = 0 To ModuleEventArray.Length - 1
For j As Integer = i + 1 To ModuleEventArray.Length - 1
'test if ModuleEventArray(i) overlaps with ModuleEventArray(j)
Next
Next
ModuleEvent here would be another class or structure that has fields startTime and endTime. The test
if (startTime1 <= endTime2 or endTime1 >= startTime2)
is not enough to test for overlap, but maybe you can figure out the correct test yourself :)
EDIT:
Since I see you use some sort of collection, not array, the code you need should be something like:
For i As Integer = 0 To eventTime.Count - 1
For j As Integer = i + 1 To eventTime.Count - 1
If (eventTime.Item(i).Start_Date_Time < eventTime.Item(j).End_Date_Time) And (eventTime.Item(i).End_Date_Time > eventTime.Item(j).Start_Date_Time) Then
MsgBox("Clash")
Else
MsgBox("No Clash")
End If
Next
Next
Before you write your code, you need to first decide what your algorithm is going to be. For example, if you use the naive method your presume, the code is indeed straightforward (basically 2 nested loops) but the complexity if O(n²).
Depending on how much data you have, whether it is in a database, how likely you expect clashes to be, whether you always have the full list of events at the start or you need to find clashes incrementally, etc... different solutions might be preferred. One consideration is whether you need to partition the list into non-clashing sets of events or just produce a yes/no answer (one one for each event) stating whether there is a clash.
You might consider doing something different instead, like sorting the list by start time before you start comparing. That will allow you to walk the list only once.
My comparisons are coming from the database. Prior to the code below I have a query which returns all the records from my Events table, based on the user input of a Module_Code. This code will show the clashes, through a msgbox. I will be changing it to populate a list. It's not the prettiest and will probably lead to a lot of duplication but it achieves my main objective.
For Each evnt In eventTime
Dim startTime1 = evnt.Start_Date_Time
Dim endTime1 = evnt.End_Date_Time
For Each evat In eventTime
Dim startTime2 = evat.Start_Date_Time
Dim endTime2 = evat.End_Date_Time
If (startTime1 < endTime2) And (endTime1 > startTime2) Then
MsgBox("Clash")
Else
MsgBox("No Clash")
End If
Next
Next