Calculating Data in VBA Excel Where conditions can vary - excel

I am coaching a rifle shooting team and I am designing a program to analyse the data, all the data required is stored in a large denormalized on a sheet in excel. I am hoping to calculate statistics for each shooter such as Average Score, Top Score, Std Dev etc. How ever on my summary sheet I also need a bunch of variables to filter the data with such as Day of the year, time of day, distance shot, the year.
I am attempting to design my own fuctions such as
Public Function AveScore(ShooterID As String, YearShot As Integer, Optional Day As String = "All Year", Optional TimeOfDay As String = "All Day", Optional Distance As String = "All", Optional OutOf As Integer = 40, Optional TopShots As Integer = 0, Optional AdjOutOf As Boolean = True) As Double
This then I will be able to call easily on my sheets and allow me to easily adapt my format. However due to the nature of the filters they will sometimes filter some data and other times I would like all data in those areas. Each filter corresponds to a field in the table.
I found that using loops to calculate the results ended up with many many overwhelming if statements which was unrealistic because I had to account for each eventuality for when certain conditions were needed or not
the following is my attempt as writing it by creating an excel formula through if statements then evaluating this
Public Function AveScore(ShooterID As String, YearShot As Integer, Optional Day As String = "Al Year", Optional TimeOfDay As String = "All Day", Optional Distance As String = "All", Optional OutOf As Integer = 40, Optional TopShots As Integer = 0, Optional AdjOutOf As Boolean = True) As Double
'if TopShots is 0 then no top and show all shots
Dim formula As String: formula = "{=AVERAGE("
Dim top As Boolean: top = False
Dim i As Integer
'check if they want to look at the top shots
If TopShots <> 0 Then
top = True
formula = formula + "LARGE("
End If
'add 2 if statements that check year and shooterID
formula = formula + "IF(DenormalizedTable[Year]=" & YearShot & ",IF(DenormalizedTable[ShooterID]=" & Chr(34) & ShooterID & Chr(34) & ","
Dim counter As Integer: counter = 2
'check if its a day or period the add the IF statement
If Day <> "All Year" Then
Set c = Lists.Range("PeriodList").Find(Day, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
formula = formula + "IF(DenormalizedTable[Period]=" & Chr(34) & Day & Chr(34) & ","
counter = counter + 1
Else
Set c = Lists.Range("DayList").Find(Day, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
formula = formula + "IF(DenormalizedTable[Day]=" & Chr(34) & Day & Chr(34) & ","
counter = counter + 1
End If
End If
End If
'and the time of day if
If TimeOfDay <> "All Day" Then
formula = formula + "IF(DenormalizedTable[TimeOfDay]=" & Chr(34) & TimeOfDay & Chr(34) & ","
counter = counter + 1
End If
'Add the distance IF
If Distance <> "All" Then
formula = formula + "IF(DenormalizedTable[Distance]=" & Distance & ","
counter = counter + 1
End If
formula = formula + "DenormalizedTable[%Score]"
'add the brackets for the IFs
For i = 1 To counter
formula = formula + ")"
Next i
If top Then
formula = formula + ",{"
For i = 1 To TopShots
formula = formula + i
If i <> TopShots Then
formula = formula + ","
End If
Next i
formula = formula + "})"
End If
formula = formula + ")*" & OutOf & "}"
MsgBox formula
AveScore = Evaluate(formula)
End Function
How ever this function also seems very impractical and unextendable for the other functions I wish to write
I was hoping someone would be able to suggest a way I might achieve this analysis that is practical
I am only new to coding and do not have the best knowledge of prebuilt functions however I have done lots of research and could not find anything that would help me

Related

Using Dictionary (hashing) in VBA

I have an excel workbook with multiple sheets.
I have to get counts of certain entries by using filters(i'm searching text instead of using filters here)
The "Main" sheet is where the count is updated. The strings are searched from other sheets in the workbook
The cells where the count should be updated varies.
The search criteria,keyword,sheet,range, etc is given in the sample code which I have posted.
Example from code:
In Cell, AE43, the count is updated only when the sheet "TT" meets the criteria mentioned.
So, similarly I'll have to use the same kind of code 30+ times for different cells to get the data.
So instead of typing the code for similar search, I want to know whether we can use "Dictionary" function (hashing in other languages) here, so that a cell can be updated automatically if it meets the criteria.
Sub WBR()
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
With ActiveWorkbook.Worksheets("TT") 'no of tickets processed - summary
[AE43] = wf.CountIfs(.Range("I:I"), "<>Duplicate TT", _
.Range("G:G"), "<>Not Tested", _
.Range("U:U"), "Item")
End With
With ActiveWorkbook.Worksheets("TT") 'not tested tickets - summary
[AE44] = wf.CountIfs(.Range("G:G"), "Not Tested")
End With
With ActiveWorkbook.Worksheets("TT") 'Tickets moved back- outdated OS and App Versions - summary
[AE45] = wf.CountIf(.Range("I:I"), "Outdated App Version") + wf.CountIf(.Range("I:I"), "Outdated OS")
End With
Here's a basic example which should get you started.
Sub showing how to call the code:
Sub Tester()
With ThisWorkbook.Sheets("Main")
.Range("A1") = GetCount("TT", False, "A:A", "Blue")
.Range("A2") = GetCount("TT", False, "A:A", "Blue", "C:C", "Red")
.Range("A3") = GetCount("TT", True, "A:A", "Blue", "C:C", "Red")
End With
End Sub
Generalized version of your use cases:
'If addValues is True and there are >1 set of criteria then
' sum up a bunch of COUNTIF(), else use COUNTIFS() so all
' criteria are applied at the same time
Function GetCount(shtName As String, addValues As Boolean, _
ParamArray crit()) As Long
Dim sht As Worksheet, f As String, num As Long, i As Long
Set sht = ThisWorkbook.Sheets(shtName)'<< counting things on this sheet
num = UBound(crit)
If num = 1 Or addValues Then
f = "COUNTIF(" & crit(0) & ",""" & crit(1) & """)"
End If
If num > 1 Then
If addValues Then
'already got the first pair: add the rest
For i = 2 To num Step 2
f = f & " + COUNTIF(" & crit(i) & ",""" & crit(i + 1) & """)"
Next i
Else
f = "COUNTIFS("
For i = 0 To num Step 2
f = f & crit(i) & ",""" & crit(i + 1) & """"
If i <> num - 1 Then f = f & ","
Next i
f = f & ")"
End If
End If
If f <> "" Then
Debug.Print f
GetCount = sht.Evaluate(f) '<<do not use Application.Evaluate here
Else
GetCount = -1 '<< something went wrong...
End If
End Function
Debug output:
COUNTIF(A:A,"Blue")
COUNTIFS(A:A,"Blue",C:C,"Red")
COUNTIF(A:A,"Blue") + COUNTIF(C:C,"Red")
Probably could use some error-handling and if there are other use cases you'll need to add those in.

Join rows based on unique ID

I have 32.000 rows with data. Some data are in a different place and I want to join them with something that I can apply to all rows and not manually. Each "group" have the same ID, in this example is "XPTO"
I have something like this now (but with more columns):
I want it to be like this:
The problem is that I need a clever way, because they are not always exactly like this example. Some of them have 10 rows with the same ID "XPTO" (example)
I am struggling with this =/ ty
Here's how I would approach this.
1) From your comment, I understand that the logic is positional (the first one on the left (Casteloes de) goes with the first one on the right (R Dr Antonio) for the matching value in column A. If that is true, then I would insert a column where you start numbering sequentially, then Fill Down to get sequential numbers all the way to the end. This will help preserve the positional logic if you need to sort or rearrange your data. It will also help you with the logic of "first match", "second match", etc.
2) My next step would be to separate the two sets of data into separate tables/tabs (with the sequentially numbered column appearing in each) and use INDEX/MATCH. The recent answer here will help you with how to increment the match: Is there such thing as a VLOOKUP that recognises repeated numbers?
3) Alternative - this may even be easier, although you'll want to do extensive data checking to make sure nothing got screwed up. With the two tables from step 2, sort by any column with data in it, then delete the blank rows from each table. Then, sort each by the sequentially numbered column to return to the original order. At that point you may be able to just copy and paste. Check carefully for errors if you do this.
I am positive that the solution above given by CriketBird work, at least it has a good logic to solve it, but since I am a newbie in excel, I couldn't figure it out how to solve it that way.
So I solved it by using VBA in excel...(maybe I went too far for this simple problem, but it was my only option).
I will leave the code here if someone want it for a similar situation. (just select the first column and row your table starts and hit run)
Function Area(medico As String) As Integer
Do While countOk < 1
If medico = ActiveCell.Value Then
ActiveCell.Offset(1, 0).Select
rowCount = rowCount + 1
Else: countOk = 1
End If
Loop
Area = rowCount
End Function
Sub Teste()
Dim PaginaMedico As String
Dim totalrowCount As Integer
Dim rowCount As Integer
Dim countOk As Integer
Dim right As Integer
Dim left As Integer
Dim listaleft As New Collection
Dim listaright As New Collection
rowCount = 1
rowOk = 0
totalrowCount = 0
right = 0
left = 0
Do While ActiveCell.Value <> 0
PaginaMedico = ActiveCell.Value
rowCount = Area(PaginaMedico)
totalrowCount = totalrowCount + rowCount
Range("A" & (totalrowCount - (rowCount - 1))).Select
For i = ((totalrowCount + 1) - rowCount) To totalrowCount
If IsEmpty(Range("E" & (i)).Value) And IsEmpty(Range("F" & (i)).Value) Then
Range("T" & (i)).Value = "Empty"
ElseIf Not IsEmpty(Range("E" & (i)).Value) And Not IsEmpty(Range("F" & (i)).Value) Then
Range("T" & (i)).Value = "Full"
ElseIf Not IsEmpty(Range("E" & (i)).Value) And IsEmpty(Range("F" & (i)).Value) Then
left = left + 1
listaleft.Add i
ElseIf IsEmpty(Range("E" & (i)).Value) And Not IsEmpty(Range("F" & (i)).Value) Then
right = right + 1
listaright.Add i
End If
Next i
If Not (right = left) Then
Range("T" & totalrowCount).Value = "BOSTA"
right = 0
left = 0
End If
If listaleft.Count = listaright.Count Then
For i = 1 To listaleft.Count
Range("F" & listaright(1) & ":" & "S" & listaright(1)).Cut Range("F" & listaleft(1) & ":" & "S" & listaleft(1))
listaright.Remove (1)
listaleft.Remove (1)
Next i
End If
Set listaleft = New Collection
Set listaright = New Collection
Range("A" & (totalrowCount + 1)).Select
Loop
End Sub

Count before executing Worksheets(X).Columns(Y).Replace function

I need to maintain a count of replacements made before implementing the Worksheets(...).Columns(...).Replace function using Excel VBA.
Can anyone guide me regarding code that I probably need to insert in *** below for counting the replacements that are about to occur in the next line of code? Thanks.
Function Value_Replace(TabName As String, ColumnTitle As String, val_Old As String, val_New As String)
Dim MyColumn, CountReplacements As Long
Dim MyColumnLetter As String
MyColumn = WorksheetFunction.Match(ColumnTitle, ActiveWorkbook.Sheets(TabName).Range("1:1"), 0)
'CountReplacements = ***?
Worksheets(TabName).Columns(MyColumnLetter).Replace _
what:=val_Old, Replacement:=val_New, _
SearchOrder:=xlByColumns, MatchCase:=False
Value_Replace = "Values " & CountReplacements & " in column " & MyColumnLetter & " updated!"
End Function
I propose to store in the cell (eg [A1]) and the number of repetitions for each call to change to increment it. But it must be the end of all calculations to clear the cell that would be the next time you call this function, the function would not start incrementing the previous value.
Some will look like this:
[A1].value = [A1].value + 1
CountReplacements = [A1].value
How about using COUNTIF with * Old_Str *? You don't need to count the actual replacements before they happen, just find out how many occurrences of Old_Str there are in your column within the contents of each cell before you start the replacement. Doing it on New_Str after you'd replaced it would be unwise unless you could guarantee there were no occurrences of New-Str before you executed the replacement .
CountReplacements = WorksheetFunction.CountIf(ActiveSheet.Columns(MyColumnLetter), "*" & val_Old & "*")
Give it a go and see
Thanks. But this worked as well:
While Not ConsecutiveEmpty = 1
If IsEmpty(Worksheets("Sheet1").Cells(LastRow, 2).Value) Then
ConsecutiveEmpty = ConsecutiveEmpty + 1
End If
LastRow = LastRow + 1
Wend
MyCount = 0
For i = 2 To LastRow
If Worksheets("Sheet1").Cells(i, MyColumn).Value = val_Old Then
MyCount = MyCount + 1
End If
Next

Display individal substrings of Split() or string of Join() function in individual cells (VBA Excel)

I'm new to VBA and cannot figure this question out for the life of me. I apologize if I'm not using the proper words to describe my problem:
I have a function in VBA that opens a URL which downloads a csv file. I have the variable assigned to that download declared "As String". Then, I split it into rows and split the relevant row (I need information in the second row) into columns. I can now use the function to display any of the information in any of the seven columns of the second row, but only one at a time. I can also use the Join() method to display the entire second row in one cell with the substrings separate by a comma.
Goal: I want to be able to customize which pieces of information (substrings) from the second row to display, and I want them displayed in their own adjacent cells (adjacent by columns). This can be accomplished by using the "Text to Columns" feature on the Data ribbon, but I want it converted in the visual basic code itself. Thank you!!
Here is my Code:
Function DailyRange(YahooTicker As String, Optional dtDate As Variant)
' Date is optional - if omitted, use today. If value is not a date, throw error.
If IsMissing(dtDate) Then
dtDate = Date
Else
If Not (IsDate(dtDate)) Then
DailyRange = CVErr(xlErrNum)
End If
End If
Dim dtPrevDate As Date
Dim strURL As String, strCSV As String, strRows() As String, strColumns() As String
Dim DailyRows As Variant
Dim dbDate As String
Dim dbHigh As Double, dbLow As Double, dbClose As Double, dbVolume As Double
dtPrevDate = dtDate - 7
' Compile the request URL with start date and end date
strURL = "http://ichart.finance.yahoo.com/table.csv?s=" & YahooTicker & _
"&a=" & Month(dtPrevDate) - 1 & _
"&b=" & Day(dtPrevDate) & _
"&c=" & Year(dtPrevDate) & _
"&d=" & Month(dtDate) - 1 & _
"&e=" & Day(dtDate) & _
"&f=" & Year(dtDate) & _
"&g=d&ignore=.csv"
' Debug.Print strURL
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.Send
strCSV = http.responseText
' Debug.Print strCSV
' THIS IS WHERE I RUN INTO THE PROBLEM
' I want the most recent information which is in row 2, just below the table headings.
' I want date, price open, high, low, close, and volume which positions are shown below
strRows() = Split(strCSV, Chr(10)) ' split the CSV into rows
strColumns = Split(strRows(1), ",") ' split the relevant row into columns. 1 means 2nd row, starting at index 0
DailyRows = Join(strColumns, ",")
dbDate = strColumns(0) ' means 1st position, date
dbHigh = strColumns(2) ' means 3rd position, price high
dbLow = strColumns(3) ' means 4th position, price low
dbClose = strColumns(4) ' 4 means: 5th position, starting at index 0
dbVolume = strColumns(5) ' means 6th position, volume
' Now, how do I display the information I want in their own cells?
'DailyRange = dbDate & dbHigh & dbLow & dbClose & dbVolume
'DailyRange = strColumns
'DailyRange = strCSV
DailyRange = DailyRows
Set http = Nothing
End Function
If you're attempting to open a CSV, why not use the Workbooks.Open() method to open the file, and then manipulate the data that way?

How to hide rows in VBA based on values in row, quickly

this is my first time using the site, so forgive me for any inept explaining. I have a working macro to hide/unhide rows based on content of the rows, I just want it to be faster. Using a check box, when the box is checked, all rows with an "x" in column D get unhidden, those without an "x" get hidden. Same thing happens when it is unchecked, except it references column C, not D.
Right now, this code works. It's just a little slower than I'd like, since I'm sharing this with a bunch of people. Any ideas for how to speed it up? I'm pretty darn new to VB (the internet is astoundingly wise and a good teacher), but that doesn't matter. I already improved the code - before it selected each row, then referenced the column, and it was awful. Any ideas to speed it up (preferably without moving the screen) would be great.
Thanks so much folks,
DS
Sub NewLuxCheck()
Dim x As Integer
NumRows = Range("A42", "A398").Rows.Count
Range("A42").Select
If ActiveSheet.Shapes("checkbox2").OLEFormat.Object.Value = 1 Then
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("D" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
Else
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("C" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
End If
MsgBox ("Done")
End Sub
You could use array formula and let Excel to return array with row-numbers where 'x' value occures. It will be quicker but you'll have to reorganise your code and create separate functions etc.
Here example where array formula finds rows whre in column 'D' the cell has value 'x'. Then string of this row numbers is created in form of "A1,A5,A10" ...means 'x' was found in rows 1,5,10. And finally Range(rowsJoind).EntireRow.Hidden is used for all the rows to be hidden/un-hidden in one step.
For rows with value different then 'x' you'll have to use formula like '=IF({0}<>""x"", ROW({0}), -1)'.
Sub test()
Dim inputRange As Range
Dim lastRow As Long
Dim myFormula As String
Dim rowsJoined As String, i As Long
Dim result As Variant
With Worksheets("Base")
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set inputRange = .Columns("D").Resize(lastRow)
Application.ReferenceStyle = xlR1C1
myFormula = "=IF({0}=""x"", ROW({0}), -1)"
myFormula = VBA.Strings.Replace(myFormula, "{0}", inputRange.Address(ReferenceStyle:=xlR1C1))
result = Application.Evaluate(myFormula)
result = Application.Transpose(result)
Application.ReferenceStyle = xlA1
For i = LBound(result) To UBound(result)
If (result(i) > -1) Then
rowsJoined = rowsJoined & "A" & result(i) & IIf(i < UBound(result), ",", "")
End If
Next i
.Range(rowsJoined).EntireRow.Hidden = False
End With
End Sub

Resources