I am making a data entry form through VBA excel. I am very new at this and was unable to get any meaningful search results as I was unsure of the name of what I was trying to do.
Anyway, the form I am making is for users to enter data collected from running audits and when "Save" button is clicked, the data from the text boxes and combo boxes is written to a new row in an excel workbook.
In my form there are four fields that identify each data entry (Year, Quarter, Day, Ward) followed by the rest of the data. I am trying to get some code to first check if there is a row with the same values already in the workbook to prevent duplicate entries.
e.g. The spreadsheet contains the following data -
YEAR -- QUARTER---- DAY--- WARD
2013----------1--------- Monday -- ICU
2013----------2--------- Monday -- ICU
2013----------3--------- Monday -- ICU
2013----------4--------- Monday -- ICU
2014----------1--------- Monday -- ICU
And a user enters a new entry with the following values
Year - 2014
Quarter - 1
Day - Monday
Ward - ICU
I need some code that would give a result (Msgbox saying duplicate entry etc)
but if they entered one that was
Year - 2014
Quarter - 2
Day - Monday
Ward - ICU
All is ok and they are able to click "save"
I appreciate your help (sorry for the dumb question!)
Here's a code fragment (Function IsDuplicate()) which loops through a range until the first blank row (to be precise to the first row where the fist column is empty) and compares 4 key fields with 4 parameters you are providing.
You can call this from your Save button and, depending on the outcome, proceed with writing and closing the form or refuse the writing and display a MsgBox.
Sub Test()
Dim DTab As Range
Set DTab = ActiveSheet.[B3] ' define start of data table
If IsDuplicate(DTab, 1, 1, 1, 1) Then ' your form input here instead of 1,1,1,1
MsgBox ("duplicate")
' stay in form
Else
MsgBox ("unique")
' write record and close form
End If
End Sub
Private Function IsDuplicate(DRange As Range, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant) As Boolean
Dim Idx As Long
IsDuplicate = False
Idx = 2 ' 1st row is header
Do While DRange(Idx, 1) <> "" ' break at 1st blank row
If DRange(Idx, 1) = P1 And _
DRange(Idx, 2) = P2 And _
DRange(Idx, 3) = P3 And _
DRange(Idx, 4) = P4 Then
IsDuplicate = True
Exit Do
End If
Idx = Idx + 1
Loop
End Function
You will need this function quite often .... sometimes you want to return Idx instead of just a True/False to return the number of the record - if you must decide whether to Insert/Append or Update a record.
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 :)
Wording my question is slightly tricky so I've included screen-shots to make this easier. I have 2 separate spreadsheets which are currently not linked together in anyway. What I've been asked to do is:
For the drop-downs which have a * next to them, have this * drop-down get converted into a acronym (I.e. If it's Home Visit *, then this will be converted to HV), and have it automatically entered into Cell Position X. Please refer to Image 1 then Image 2)
So the user would click on Sheet one, select the relevant drop-down field and then assign how much time that task took. The second sheet would then update itself with this information - it would insert the users name, program and activities. This is where it gets very tricky. Based off the drop-down selection, if it is asterisked (*), then based off the field-type it will convert it into a set acronym which would then be placed in one of the data fields based off the entry date that has been provided.
I designed both spread-sheets and they have macros in the background, but I can't seem to work out how to best perform this. Would you suggest a transpose function which checks firstly the date criteria and then an INDEX(MATCH) function to match the criteria against a pre-defined name-range which converts Home Visit etc. to HV automatically? I'm also unsure of how to insert delimiters for each new entry that is read. If anyone can provide help I would be very grateful.
I'm not 100% sure I understand your question, but here goes:
What about adding a Worksheet_Change event to look for changes in the drop-down's cell, and then converting it to an acronym?
Place the following code inside the sheet of interest:
Private Sub Worksheet_Change(ByVal Target As Range)
'If Cell A1 is changed, put the acronym into A2
If Target.Row = 1 And Target.Column = 1 Then
Cells(2, 1) = GetAcronym(Target.Value)
End If
End Sub
Function GetAcronym(TheText As String) As String
Dim result As String
Dim x As Long
'Always grab the first letter
result = Mid(TheText, 1, 1)
'Get the other letters
For x = 2 To Len(TheText) - 1
If Mid(TheText, x, 1) = " " Then result = result & Mid(TheText, x + 1, 1)
Next x
GetAcronym = UCase(result)
End Function
In my excel sheet I have an varying number of dates in column A with associated totals for each date in column B. The dates are somewhat random but I want to find the sum of the associated totals per week. I'm new to vba and I'm having a bit of trouble figuring out how to calculate the totals per week.
The psudo code for what I'm thinking is:
buttonClicked()
Dim sum As Integer, tempDate As Date, current As Date, i As Integer, j As Integer, match As Boolean
sum = 0
tempDate = Range("A1").Value
current = tempDate
For i = 1 To Rows.Count
for j = 0 to 7
tempDate = addDate(d, i, tempDate)
If cell(i,1).Value = tempDate Then sum = sum + cell(i, 2).Value
match = true
Break
End If
Next j
If match = true Then tempDate = current
Else
`next open space in column D is current
current = tempDate
`next open space in column E is sum
sum = 0
Next i
end
Please let me know if there's any better way to solve this problem other than iterating through the entire list and counting 7 days ahead. I should note that A1 is already assumed to be a sunday and I'm not sure how the commented out lines should be implemented. I would be very grateful for any advice at all.
In other column assign the corresponding Year.WeekNumber to each row using the following formula:
=CONCATENATE(YEAR(A1),".",TEXT(WEEKNUM(A1),"00"))
The totals per Year.Week can be obtained using a SUMIF formula or via a PivotTable. The PivotTable can be auto resize if you use a Dynamic Range as DataSource
If you are looking for a series of 7 row sums from column B, then this formula using native worksheet functions should do.
=SUM(INDEX(B:B, (ROW(1:1)-1)*7+1):INDEX(B:B, (ROW(1:1)-1)*7+7))
Fill down to catch successive week periods.
If you can supply a starting date (e.g. =MIN(A:A)) and add 7 to it in successive rows, then the weekly starting date could be a reference point for a SUMIFS function. In E9 as,
=SUMIFS(B:B,A:A, ">="&D9,A:A, "<"&D9+7)
Fill down as necessary.
If a VBA solution is necessary, that logic can be brought into a VBA sub or function.
I use the sub below as part of another sub which error checks and saves a grade sheet. There will be at least 39 grade sheets generated throughout the course this is built for. Each event may be accomplished more than once - a weather cancel, or student failed.
The FindEmptyInsertData sub takes the three most important data from a grade sheet (Date, Grade, Status) and adds them to a sheet named Index. Index then keeps a running tally on the events accomplished...based solely on the output of the 'Error Check and Save' macro.
My question is more of a logic question, rather than for specific code (although it'll help). FindEmptyInsertData works wonderfully. However, the data gets pushed and added to Index however many times the user clicks the 'Error Check and Save' Form Control button. I would like it to only get pushed once per grade sheet...the problem/challenge is that a user might need to go back and change the grade sheet (wrong date, different status...etc).
Index looks like this:
Event ABC-1 ABC-2 DEF-1 DEF-2
Date dd-mmm dd-mmm dd-mmm dd-mmm
Grade 1 2 2 3
Status WX EFF EFF EFF
---- ---- ---- ----
Date dd-mmm
Grade 3
Status EFF
I'm thinking that my solution will lie in the fact that only one event will ever be attempted/accomplished per day. Therefore...if date of gradesheet matches the date in index, then don't push the data again...except if the grade or status changes. Ugh, my brain hurts!
Thanks in advance!
Sub FindEmptyInsertData()
Dim ws As Worksheet
Dim gsDate As Date
Dim gsWorking As String
Dim gsMsnNum As String
Dim colNum As Integer
gsWorking = ActiveWindow.ActiveSheet.Name
gsDate = ActiveSheet.Range("S3")
gsGrade = ActiveSheet.Range("D40")
gsStatus = ActiveSheet.Range("O7")
gsMsnNum = ActiveSheet.Range("D3")
Application.ScreenUpdating = False
'Opens up the INDEX (Sheet4) and finds the first empty cell
Sheet4.Activate
Sheet4.Unprotect
'Finds the sortie name column in INDEX
For Each Cell In ActiveSheet.Rows(5).Cells
If Cell = gsMsnNum Then Cell.Select: Exit For
Next Cell
'Takes the active column number and assigns it to the variable
colNum = ActiveCell.Column
'Finds the first open cell in that column
For Each Cell In ActiveSheet.Columns(colNum).Cells
If Len(Cell) = 0 Then Cell.Select: Exit For
Next Cell
ActiveCell.Value = gsDate 'Prints the Date from the GS into the first empty cell
ActiveCell.NumberFormat = "dd-mmm"
Selection.Offset(1, 0).Select 'Moves One Cell Down
ActiveCell.Value = gsGrade 'Prints the Grade from the GS
Selection.Offset(1, 0).Select 'Moves One Cell Down
ActiveCell.Value = gsStatus 'Prints the Status from the GS
ActiveCell.Borders(xlEdgeBottom).Weight = xlMedium 'Adds a bottom border
'Protects the Index Page
Sheet4.Protect
'Returns to the Previously open GS
Worksheets(gsWorking).Activate
End Sub
Without seeing your Index and other code involved, this is the best recommendation I could make.
Conceptually, as far as simple database design goes, you might benefit from adding a 5th row for Event Sequence.
Add an integer variable to your code that looks for the sequence and when assigning data for an event. Increment it by 1 when adding event data to the index. If you hate the idea of consuming an entire row you can also tell your code to hide the row.
This way you can have as many entries containing same or different data as necessary. You can choose to accept the "Event" and highest number for "Sequence" as the final submitted grade by default.
Event ABC-1 ABC-2 DEF-1 DEF-2
-------------------------------------
Seq 1 1 1 1 ' <--- Pull data by Event Name & Sequence
Date dd-mmm dd-mmm dd-mmm dd-mmm
Grade 1 2 2 3
Status WX EFF EFF EFF
---- ---- ---- ----
Seq 2 ' <--- Pull data by Event Name & Sequence
Date dd-mmm
Grade 3
Status EFF
Additionally, you could add another row to the Index that would contain data for which event is the active one that you have pushed to the grade sheet.
Event ABC-1 ABC-2 DEF-1 DEF-2
-------------------------------------
Seq 1 1 1 1 ' <--- Pull data by Event Name & Sequence
Date dd-mmm dd-mmm dd-mmm dd-mmm
Grade 1 2 2 3
Status WX EFF EFF EFF
Active 0 1 1 1
---- ---- ---- ----
Seq 2 ' <--- Pull data by Event Name & Sequence
Date dd-mmm
Grade 3
Status EFF
Active 1
Thank you so much for your answer! I had the same kind of idea as you as I went to bed last night thinking about how to solve this...to give each event a unique identifier that gets pulled along with the other data. I knew this was going to be more of a logic type answer, with multiple ways to solve (like anything in life, eh?).
BUT...what I ended up going with (for now at least), was sticking with using the Date tied to the Event Name as the 'unique' qualifiers. I realize that there are some gaps in this logic (what if the date gets changed after the data push?) that your solution will solve. But, the date is auto generated with the Grade Sheet, so I'm hoping the occurrence will be virtually non-existent.
For anyone else out there reading my first(!) post here, here's my solution:
'Finds the Event name column in INDEX
For Each Cell In ActiveSheet.Rows(5).Cells
If Cell = gsMsnNum Then Cell.Select: Exit For
Next Cell
'Takes the active column number and assigns it to the variable
colNum = ActiveCell.Column
'Finds a date match in that column
For Each Cell In ActiveSheet.Range(Cells(6, colNum), Cells(40, colNum))
If Cell.Value = gsDate Then Cell.Select: Exit For
Next Cell
'If the date is the same, it will overwrite the grade and status
If ActiveCell.Value = gsDate Then
Selection.Offset(1, 0).Select 'Moves One Cell Down
ActiveCell.Value = gsGrade 'Prints the Grade from the GS
Selection.Offset(1, 0).Select 'Moves One Cell Down
ActiveCell.Value = gsStatus 'Prints the Status from the GS
Pick up my previous code where I match the event name on the INDEX page going across row 5. Then, I assign the column number to the colNum variable.
Now, the new code: Since I grabbed the date from the Grade Sheet, I use the matched Event's column to search down to find the matching date. If it finds a matching date, then it will overwrite the old with the new Grade and Status. Otherwise, it will continue on with the code as previously written and find the first empty cell in the Event column and print the Date, Grade, and Status.
I hope this helps someone out there think through solving their problems, or at least gets you thinking towards a constructive solution...or you just learn something new, like I did!
I've gone from zero VBA knowledge to where I'm at now (still very much learning, but dangerous enough to impress the bosses) within a matter of just a couple weeks thanks to this website and everyone who contributed. THANK YOU THANK YOU THANK YOU!!!!
I have an excel sheet with lots of data. As you may know, this comes with lots of problems. One major one is having too much data. I am not familiar with vba, but I wanted to know how to clean data.
I have a sheet with 3 fields: date, time, and temp. The temperature is recorded on a minute by minute basis. The temperature is only recorded from 7 am to 10 pm, but the sheet is on a 24 hour basis. So my sheet has a lot of blank cells. So, I want to write a code that states:
if ((time < 7am) or (time > 10pm)):
delete row
Can I do this?
Also, another problem is that the data is not collected on weekends. I am not given a day field, only a date field in this format: 20130102 which is January 02 2013. I want to:
if ((date = saturday) or (date = sunday)):
delete row
Are either of these doable?
My sheets looks like the following:
A .............. B ......... .... C
date........ time ......... temp
Since both your dates and times are formatted differently than normal, we need to manipulate the values to get something to test against. Consider the following example (I've commented each line to help you follow along):
Sub DeleteRows()
Dim lastRow As Long
Dim Cell As Long
Dim dt As Date
'Work with the active sheet.
With ActiveSheet
'Find the last row of your dataset.
lastRow = .Range("A:A").Find("*", searchdirection:=xlPrevious).Row
'Format your time column to a readable time.
.Columns("B").NumberFormat = "[$-F400]h:mm:ss AM/PM"
'Loop through the rows, beginning at the bottom.
For Cell = lastRow To 2 Step -1
'Piece together the date.
dt = Mid(.Cells(Cell, 1), 7, 2) & "/" & _
Mid(.Cells(Cell, 1), 5, 2) & "/" & Left(.Cells(Cell, 1), 4)
'If the date is a Sat or Sun, delete the row.
If Weekday(dt) = 1 Or Weekday(dt) = 7 Then
.Rows(Cell).EntireRow.Delete
'If the time is before 7am or after 10pm, delete the row.
ElseIf Hour(.Cells(Cell, 1)) < 7 Or Hour(.Cells(Cell, 1)) > 22 Then
.Rows(Cell).EntireRow.Delete
End If
Next Cell
End With
MsgBox "Done!"
End Sub
A few things to note about the code. First, we must start at the bottom of the list because as we delete rows, the remaining rows shift upwards. If we were to go from top to bottom (e.g. A1 to A10), if we deleted row 5, row 6 would slide into its place, and the loop would skip row 5 (previously row 6) and go on to row 6. In other words, looping from top to bottom when deleting rows will ultimately skip rows unintentionally.
Second, I had to guess on your time format. While I believe I guessed correctly, I may not have. If I was wrong and my code doesn't change the time column into a readable time, record a macro while changing the format of that column and substitute the new format with mine ("[$-F400]h:mm:ss AM/PM"
).
And lastly, since your date column is an abnormal format (for Excel), we need to reorder the date so that Excel can read it. Once we've done that, we can use the resulting date to see if the date was a Sat. or Sun.
You can do it this way, assuming the column that contains your date is the 2nd (B) :
Dim i As Integer
for i = 1 to cellsCount
If Hour(Cells(i, 2)) < 7 Or Hour(Cells(i, 2) > 22 Then
Rows(i).Delete
Else If WeekDay(Cells(i, 2)) = 7 Or WeekDay(Cells(i, 2)) = 1 Then
Rows(i).Delete
End If
next
You can have more information about the WeekDay function here :
http://msdn.microsoft.com/en-us/library/82yfs2zh%28v=vs.90%29.aspx