I have a VBA challenge, I have spent quite some time trying to solve. I am using the project management template sheet that is to be found on this link:
https://www.vertex42.com/ExcelTemplates/excel-gantt-chart.html
In this I would like to make a function, that finds the minimum and max date of the levels below automatically.
E.g. in row 8 where the WBS is 1, I would like a function in column E that finds the max date of all the rows that start with 1 (e.g. 1.1, 1.2, 1.3)
I have tried this:
Function maxIfs(maxRange As Range, criteriaRange As Range, criterion As \Variant) As Variant
maxIfs = Empty
For i = 1 To maxRange.Cells.count
If Left(criteriaRange.Cells(i).text, findN(criteriaRange.Cells(i).value)) = Criteria.value Then
If maxIfs = Empty Then
maxIfs = maxRange.Cells(i).value
Else
maxIfs = Application.WorksheetFunction.Max(maxIfs, maxRange.Cells(i).value)
End If
End If
Next
End Function
Function findN(text As Variant) As Integer
'Gives the position of the nth delimiter
Dim found As Integer
Dim place As Integer
found = 0
place = 0
For i = 1 To Len(text) + 1 ' Add 1 as we start at 1 not zero
place = found 'this will be 0 the first time round
found = InStr(found + 1, text, ".")
Next i
findN = place
End Function
I think the issue with the code is, that the WBS column is a function, and therefore there is some issues with the if statement. However, I am not sure if this is true, or how to solve this. Do you have any suggestions?
Related
I am having trouble getting Variants to subtract. I am pulling data from a spreadsheet and if one cell states a phrase then I need the code to subtract one cell from another. If the cell does not state a phrase then I need it to copy one cell to another. I can get the code to run but nothing happens.
Private Sub CommandButton1_Click()
Dim x As Variant, y As Variant, z As Variant, a As Integer, B As String
'getting values for data
x = Range("D2:D48").Value
y = Range("I2:I48").Value
z = Range("E2:E48").Value
B = "Total ISU Days: "
'The the cells are empty then subtract. This is not what I wanted to do but I can't think of extracting strings from variants.
If IsEmpty(Range("D2:D48").Value) = True Then
a = y - z
End If
Range("N2:N48").Value = a
Range("M2:M48").Value = B
End Sub
x = Range("D2:D48").Value
y = Range("I2:I48").Value
z = Range("E2:E48").Value
A Variant contains metadata about its subtype. In this case, x, y, and z are all arrays of variants.
a = y - z
The right-hand side of this expression simply cannot be evaluated, because {array1} - {array2} means nothing: operators (arithmetic or logical) work off values, not array of values.
What is a supposed to be? It's declared As Integer, so its value is capped at 32,767 (should probably be a Long). If you mean to add up all the values in y and subtract that total from the sum of all values in z, then you need to be more explicit about how you do that - you could use Application[.WorksheetFunction].Sum to add things up:
sumOfY = Application.Sum(Range("I2:I48"))
sumOfZ = Application.Sum(Range("E2:E48"))
a = sumOfY - sumOfZ
And then...
Range("N2:N48").Value = a
That will put the value of a in every single cell in the N2:N48 range - is that really what you mean to do?
Or maybe you meant to do this instead?
Range("N2:N48").Formula = "=IF(D2="""",I2-E2,0)"
That would make each cell in N2:N48 calculate the difference between I and E for each row where D is empty... and there's not really any need for any VBA code to do this.
Let's simplify a bit the task and say that the idea is to substract the values in Range("C1:C6") from the corresponding values in the left - Range("B1:B6"). Then write the corresponding results in column E:
Of course, this would be done only in case that all values in column A are empty. This is one way to do it:
Sub TestMe()
Dim checkNotEmpty As Boolean: checkNotEmpty = False
Dim substractFrom As Range: Set substractFrom = Worksheets(1).Range("B1:B6")
Dim substractTo As Range: Set substractTo = Worksheets(1).Range("C1:C6")
Dim MyCell As Range
Dim result() As Variant
ReDim result(substractFrom.Cells.Count - 1)
Dim areCellsEmpty As Boolean
For Each MyCell In substractFrom
If Len(MyCell) > 0 Then checkNotEmpty = True
Next
Dim i As Long
For i = LBound(result) + 1 To UBound(result) + 1
result(i - 1) = substractFrom.Cells(i) - substractTo.Cells(i)
Next
Worksheets(1).Range("E1").Resize(UBound(result) + 1) = Application.Transpose(result)
End Sub
The code could be improved further, saving all ranges to an Array, but it works quite ok so far.
The part with the +1 and -1 in the For-loop is needed as a workaround:
For i = LBound(result) + 1 To UBound(result) + 1
result(i - 1) = substractFrom.Cells(i) - substractTo.Cells(i)
Next
because the arrays start from index 0, but the Cells in a range start with row 1.
Worksheets(1).Range("E1").Resize(UBound(result) + 1) = Application.Transpose(result) is needed, to write the values of the result array to the column E, without defining the length of the range in E.
I am working on a project and was wondering if there might be a faster way of doing something that seems easy, but is fairly time consuming.
Pretend I have a 10 cell column filled with random integers from 1-10:
1
1
1
5
5
8
8
8
9
9
I want to get a count of x+ occurrence of this column. Func(1)=4 [since there are 4 unique values with at least 1 occurrence]; Func(2) =4; func(3)=2 [since only 2 unique values occur at least 3 times]
Right now I filter through each possible integer, then count occurrences. If occurrences >=x then count +=1. Then cycle through through each integer. It work, but on larger ranges of cells with greater range of integers, it is a bit slow. Given Excel's flexibility and the power of VBA, I'm wondering if anyone has an idea that is more efficient.
One approach might be using a function like the below (but you'll need to add a reference by doing: Open VB Editor > Click Tools > References > Scroll down to "Microsoft Scripting Runtime" > Tick it > Click OK)
Option Explicit
Public Function CountNumericOccurrences(ByVal someRange As Range, ByVal minimumOccurrenceCount As Long) As Long
' "someRange" can be a contiguous or non-contiguous range of cells
' "minimumOccurrenceCount" is how many occurrences must be present before that value is counted.
' This function will only count numbers (strings, blanks, etc are ignored).
Dim uniqueCounts As Scripting.Dictionary
Set uniqueCounts = New Scripting.Dictionary
Dim contiguousArea As Range
For Each contiguousArea In someRange.Areas
If contiguousArea.Cells.Count > 1 Then ' Unlikely that range would contain any single-cell areas
Dim inputToCheck As Variant
inputToCheck = contiguousArea.Value
Dim rowIndex As Long
Dim columnIndex As Long
Dim currentKey As String
For rowIndex = LBound(inputToCheck, 1) To UBound(inputToCheck, 1)
For columnIndex = LBound(inputToCheck, 2) To UBound(inputToCheck, 2)
If Application.IsNumber(inputToCheck(rowIndex, columnIndex)) Then ' IsNumeric returns True for vbEmpty, so isNumber is used instead.
currentKey = CStr(inputToCheck(rowIndex, columnIndex))
If Not uniqueCounts.Exists(currentKey) Then uniqueCounts.Add currentKey, 0 ' Default value
uniqueCounts(currentKey) = uniqueCounts(currentKey) + 1
End If
Next columnIndex
Next rowIndex
ElseIf Application.IsNumber(contiguousArea) Then ' Handle single-cell edge case
currentKey = CStr(contiguousArea) ' We repeat ourselves here. Could create a "default dictionary" class, but only 3 lines repeated.
If Not uniqueCounts.Exists(currentKey) Then uniqueCounts.Add currentKey, 0 ' Default value
uniqueCounts(currentKey) = uniqueCounts(currentKey) + 1
End If
Next contiguousArea
For rowIndex = 0 To (uniqueCounts.Count - 1)
If uniqueCounts.Items(rowIndex) >= minimumOccurrenceCount Then
CountNumericOccurrences = CountNumericOccurrences + 1
End If
Next rowIndex
End Function
If you put it into a new module, you can call it from the worksheet as such:
I tested it with a range consisting of 200k cells, and it took ~4 seconds (quite slow). Maybe using a collection would be a better approach.
You could also just call it as part of a regular procedure e.g.:
Option Explicit
Private Sub SomeProcedure()
Dim someValue As Long
someValue = CountNumericOccurrences(ThisWorkbook.Worksheets("Sheet1").Range("A1:A200000"), 3)
MsgBox someValue
End Sub
While trying to use COUNTIF and SUMIF with a table that regularly has long comments, I kept getting a #VALUE error. A little bit of research said that the error could be due to the criteria string topping the 256 character point.
Any suggestions on how to get around this? I've worked out a solution I'll be posting as an Answer, but I'd like to see if anyone else has a Better Way.
I ended up writing a pair of UDFs in VB to get around the issue. There's still a character limit, but now it's 2^32, rather than 2^8.
The COUNTIF variation was pretty straightforward...
Function COUNTIFLONG(rng As Range, crt As String, ExactMatch As Boolean)
Dim Cell As Range
Dim x As Integer
x = 0
For Each Cell In rng
If IsNull(Cell.Value) Then GoTo CellCont
If ExactMatch Then
If Cell.Value = crt Then
x = x + 1
End If
Else
If (InStr(Cell.Value, crt) > 0) Then
x = x + 1
End If
End If
CellCont:
Next Cell
COUNTIFLONG = x
End Function
The SUMIF variation was a bit more tricky to get it to be flexible enough for regular use.
Function SUMIFLONG(rngCrt As Range, crt As String, rngSum As Range, ExactMatch As Boolean)
Dim Cell As Range
Dim x As Integer
Dim CrtRows As Integer, CrtCols As Integer, SumRows As Integer, SumCols As Integer
Dim RowOffset As Integer, ColOffset As Integer
Dim SumDir As String
CrtRows = rngCrt.Rows.Count
CrtCols = rngCrt.Columns.Count
SumRows = rngSum.Rows.Count
SumCols = rngSum.Columns.Count
crt = Trim(crt)
x = 0
If (CrtRows <> SumRows) Or (CrtCols <> SumCols) Then
Debug.Print ("Arrays are not the same size. Please review the formula.")
Exit Function
End If
If (CrtRows <> 1) And (CrtCols <> 1) And (SumRows <> 1) And (SumCols <> 1) Then
Debug.Print ("Please restrict arrays to one column or row at a time.")
Exit Function
End If
'Detects the offset of the Sum row/column from the Criteria row/column
RowOffset = rngSum.Row - rngCrt.Row
ColOffset = rngSum.Column - rngCrt.Column
For Each Cell In rngCrt
'Ignores Null cells or rows where the Sum column's value is not a number.
If IsNull(Cell.Value) Or (Not IsNumeric(Cell.Offset(RowOffset, ColOffset).Value)) Then
GoTo CellCont
End If
'Adds Sum Column's value to the running total.
'If an Exact Match is not requested, will detect whether Criteria is present in target cell.
If ExactMatch Then
If Cell.Value = crt Then
x = x + Cell.Offset(RowOffset, ColOffset).Value
End If
Else
If (InStr(Cell.Value, crt) > 0) Then
x = x + Cell.Offset(RowOffset, ColOffset).Value
End If
End If
CellCont:
Next Cell
SUMIFLONG = x
End Function
As I said, I'd like to see if anyone had better Ideas of how to accomplish this, but I hope this helps!
Without sample data any suggestion is going to involve some guesswork but it sounds like your search criteria could be chopped down to unique pieces less than the 255 character limit and wrapped in wildcards.
=COUNTIF(A:A, "*"&C2&"*")
Click for full size image
I'm trying to generate words in Column B from a list of given words in Column A.
Right now my code in Excel VBA does this:
Function GetText()
Dim GivenWords
GivenWords = Sheets(1).Range(Sheets(1).[a1], Sheets(1).[a20])
GetText = A(Application.RandBetween(1, UBound(A)), 1)
End Function
This generates a word from the list I have provided in A1:A20, but I don't want any duplicates.
GetText() will be run 15 times in Column B from B1:B15.
How can I check for any duplicates in Column B, or more efficiently, remove the words temporarily from the list once it has been used?
For example,
Select Range A1:A20
Select one value randomly (e.g A5)
A5 is in Column B1
Select Range A1:A4 and A6:A20
Select one value randomly (e.g A7)
A7 is in Column B2
Repeat, etc.
This was trickier than I thought. The formula should be used as a vertical array eg. select the cells where you want the output, press f2 type =gettext(A1:A20) and press ctrl+shift+enter
This means that you can select where your input words are in the worksheet, and the output can be upto as long as that list of inputs, at which point you'll start getting #N/A errors.
Function GetText(GivenWords as range)
Dim item As Variant
Dim list As New Collection
Dim Aoutput() As Variant
Dim tempIndex As Integer
Dim x As Integer
ReDim Aoutput(GivenWords.Count - 1) As Variant
For Each item In GivenWords
list.Add (item.Value)
Next
For x = 0 To GivenWords.Count - 1
tempIndex = Int(Rnd() * list.Count + 1)
Aoutput(x) = list(tempIndex)
list.Remove tempIndex
Next
GetText = Application.WorksheetFunction.Transpose(Aoutput())
End Function
Here's how I would do it, using 2 extra columns, and no VBA code...
A B C D
List of words Rand Rank 15 Words
Apple =RAND() =RANK(B2,$B$2:$B$21) =INDEX($A$2:$A$21,MATCH(ROW()-1,$C$2:$C$21,0))
copy B2 and C2 down as far as the list, and drag D down for however many words you want.
Copy the word list somewhere, as every time you change something on the sheet (or recalculate), you will get a new list of words
Using VBA:
Sub GetWords()
Dim Words
Dim Used(20) As Boolean
Dim NumChosen As Integer
Dim RandWord As Integer
Words = [A1:A20]
NumChosen = 0
While NumChosen < 15
RandWord = Int(Rnd * 20) + 1
If Not Used(RandWord) Then
NumChosen = NumChosen + 1
Used(RandWord) = True
Cells(NumChosen, 2) = Words(RandWord, 1)
End If
Wend
End Sub
Here is the code. I am deleting the cell after using it. Please make a backup of your data before using this as it will delete the cell contents (it will not save automatically...but just in case). You need to run the 'main' sub to get the output.
Sub main()
Dim i As Integer
'as you have put 15 in your question, i am using 15 here. Change it as per your need.
For i = 15 To 1 Step -1
'putting the value of the function in column b (upwards)
Sheets(1).Cells(i, 2).Value = GetText(i)
Next
End Sub
Function GetText(noofrows As Integer)
'if noofrows is 1, the rand function wont work
If noofrows > 1 Then
Dim GivenWords
Dim rowused As Integer
GivenWords = Sheets(1).Range(Sheets(1).Range("A1"), Sheets(1).Range("A" & noofrows))
'getting the randbetween value to a variable bcause after taking the value, we can delete the cell.
rowused = (Application.RandBetween(1, UBound(GivenWords)))
GetText = Sheets(1).Range("A" & rowused)
Application.DisplayAlerts = False
'deleting the cell as we have used it and the function should not use it again
Sheets(1).Cells(rowused, 1).Delete (xlUp)
Application.DisplayAlerts = True
Else
'if noofrows is 1, there is only one value left. so we just use it.
GetText = Sheets(1).Range("A1").Value
Sheets(1).Cells(1, 1).Delete (xlUp)
End If
End Function
Hope this helps.
I want to calculate a moving average of the last, say 20, numbers of a column. A problem is that some of the cells of the column may be empty, they should be ignored. Example:
A
175
154
188
145
155
167
201
A moving average of the last three would be (155+167+201)/3. I've tried to implement this using average, offset, index, but I simply don't know how. I'm a little bit familiar with macros, so such a solution would work fine: =MovingAverage(A1;3)
Thanks for any tips or solutions!
{=SUM(($A$1:A9)*(ROW($A$1:A9)>LARGE((ROW($A$1:A9))*(NOT(ISBLANK($A$1:A9))),3+1)))/3}
Enter this with control+shift+enter to make it an array formula. This will find the latest three values. If you want more or less, change the two instances of '3' in the formula to whatever you want.
LARGE((ROW($A$1:A9))*(NOT(ISBLANK($A$1:A9))),3+1)
This part returns the 4th highest row number of all the cells that have a value, or 5 in your example because rows 6, 8, and 9 are the 1st through 3rd highest rows with a value.
(ROW($A$1:A9)>LARGE((ROW($A$1:A9))*(NOT(ISBLANK($A$1:A9))),3+1))
This part returns 9 TRUEs or FALSEs based on whether the row number is larger than the 4th largest.
($A$1:A9)*(ROW($A$1:A9)>LARGE((ROW($A$1:A9))*(NOT(ISBLANK($A$1:A9))),3+1))
This multiplies the values in A1:A9 by those 9 TRUEs or FALSEs. TRUEs are converted to 1 and FALSEs to zero. This leaves a SUM function like this
=SUM({0;0;0;0;0;155;0;167;201})/3
Because all the values above 155 don't satisfy the row number criterion, the get multiplied by zero.
If you are going to use a UDF it will only recalculate correctly when you change the data if the parameters include all the range of data you want to handle.
Here is a moving average UDF that handles entire columns and contains some error handling. You can call it using by entering the formula =MovingAverage(A:A,3) into a cell.
Function MovingAverage(theRange As Range, LastN As Long) As Variant
Dim vArr As Variant
Dim j As Long
Dim nFound As Long
Dim dSum As Double
On Error GoTo Fail
MovingAverage = CVErr(xlErrNA)
'
' handle entire column reference
'
vArr = Intersect(Application.Caller.Parent.UsedRange, theRange).Value2
If IsArray(vArr) And LastN > 0 Then
For j = UBound(vArr) To 1 Step -1
' skip empty/uncalculated
If Not IsEmpty(vArr(j, 1)) Then
' look for valid numbers
If IsNumeric(vArr(j, 1)) Then
If Len(Trim(CStr(vArr(j, 1)))) > 0 Then
nFound = nFound + 1
If nFound <= LastN Then
dSum = dSum + CDbl(vArr(j, 1))
Else
Exit For
End If
End If
End If
End If
Next j
If nFound >= LastN Then MovingAverage = dSum / LastN
End If
Exit Function
Fail:
MovingAverage = CVErr(xlErrNA)
End Function
Just a quick solution:
Supposing your numbers are on the cells A2:A10, put in B10 the following formula:
=IF(COUNT(A8:A10)=3,AVERAGE(A8:A10),IF(COUNT(A7:A10)=3,AVERAGE(A7:A10),"too many blanks"))
Dragging up the formula you get the moving average
If there is the possibility of two consecutive blank you could nest another if, more than that and this solution became too complicated
I have written a short script in VBA. Hopefull it does what you want. Here you are:
Function MovingAverage(ByVal r As String, ByVal i As Integer) As Double
Dim rng As Range, counter As Long, j As Integer, tmp As Double
Set rng = Range(r)
counter = 360
j = 0
tmp = 0
While j < i + 1 And counter > 0
If Len(rng.Offset(j, 0)) > 0 Then
tmp = tmp + rng.Offset(j, 0).Value
End If
j = j + 1
counter = counter - 1
Wend
MovingAverage = CDbl(tmp / i)
End Function
1) I have set limit to 360 cells. It means that the script will not look for more than 360 cells. If you want to change it then change the initial value of counter.
2) The script returns not rounded average. Change the last row to
MovingAverage = Round(CDbl(tmp / i),2)
3) The use is just like you wanted, so just type =MovingAverage("a1";3) into the cell.
Any comments are welcome.