Heylo, I have been learning Excel VBA and Macros lately for fun, but I've run into a problem with a practice exercise I'm going through... I have a function that started producing a #VALUE! error with certain selected ranges and I'm slightly confused on how to fix it. The function does different calculations based on what cell is being autofilled. The function is below:
Function CalculateStuff(myRange As Range) As Double
Application.Volatile
Dim numRows As Long
numRows = myRange.Rows.Count
Dim whatColumn As Long
whatColumn = Application.Caller.Column - myRange.Column
Dim i As Long
Dim thing As Double
Dim mainThing As Double
Select Case whatColumn
Case 0
CalculateStuff = WorksheetFunction.Sum(myRange.Columns(1))
Case 1
CalculateStuff = WorksheetFunction.SumProduct(myRange.Columns(1), myRange.Columns(2))
Case 2
CalculateStuff = WorksheetFunction.SumProduct(myRange.Columns(1), myRange.Columns(3)) / WorksheetFunction.Sum(myRange.Columns(1))
Case 3
CalculateStuff = WorksheetFunction.SumSq(myRange.Columns(4))
Case 4
For i = 1 To numRows
thing = myRange(i, 1) * WorksheetFunction.SumSq(myRange(i, 3), myRange(i, 5))
mainThing = mainThing + thing
Next i
CalculateStuff = mainThing
End Select
End Function
And then I use it in a subroutine to populate the active cell's formula and autofill to the right of the active cell. The subroutine is as follows:
Sub RunCalculateStuff()
Dim initialRange As Range
Set initialRange = Application.InputBox("Please select the cells in the first column you would like to use...", Type:=8)
Dim finalRange As Range
Dim i As Long
i = 0
For Each initialCell In initialRange
If i = 0 Then
Set finalRange = ActiveSheet.Range(initialCell, initialCell.Offset(0, 4))
i = i + 1
Else
Set finalRange = Application.Union(finalRange, ActiveSheet.Range(initialCell, initialCell.Offset(0, 4)))
i = i + 1
End If
Next
ActiveCell.Formula = "=CalculateStuff(" + finalRange.Address + ")"
ActiveCell.AutoFill Destination:=ActiveSheet.Range(ActiveCell, ActiveCell.Offset(0, 4))
End Sub
The subroutine works by letting the user select the cells in the first column they would like to use, then loops through those cells and grabs the cells up to an offset of (0, 4) away and adds that range to an overall range. This range is then fed to this function and it goes.
Heres' where the #VALUE! error comes in... It only happens when the cells that I select are not sequential... By this I mean, if I select the range AA1:AA4 with the initial get box, it works just fine. If I select the range AA1, AA2, AA3, AA4 individually, it works just fine. But if I select the range AA1, AA3, I get the #VALUE! Error. I get the feeling it has something to do with skipping rows, but I really don't understand why since I'm doing a Union into its own range. Plus, it fails when I just try to sum the first column of the range in the very first calculation, then it fails in the rest as well. Screenshots below for what I mean.
Working Range:
Broken Range:
Thank you in advance for your help! I really appreciate it.
This seemed to work for me. Posting in case you did not have any luck, or if you need inspiration. Note that I didn't do any error checking to see if all the elements of your input are Ranges.
Function CalculateStuff2(ParamArray Rngs()) As Double
Dim i As Integer
Dim col As Long
Dim tmpRng As Range
Dim tmpDbl As Double
Dim divisor As Double
Dim IsCase2 As Boolean
Dim numRows As Long, r As Long
For i = LBound(Rngs()) To UBound(Rngs())
Set tmpRng = Rngs(i)
col = Application.Caller.Column - tmpRng.Column
numRows = tmpRng.Rows.Count
Select Case col
Case 0
tmpDbl = tmpDbl + WorksheetFunction.Sum(tmpRng.Columns(1))
Case 1
tmpDbl = tmpDbl + WorksheetFunction.SumProduct(tmpRng.Columns(1), tmpRng.Columns(2))
Case 2
IsCase2 = True
tmpDbl = tmpDbl + WorksheetFunction.SumProduct(tmpRng.Columns(1), tmpRng.Columns(3))
divisor = divisor + WorksheetFunction.Sum(tmpRng.Columns(1))
Case 3
tmpDbl = tmpDbl + WorksheetFunction.SumSq(tmpRng.Columns(4))
Case 4
For r = 1 To numRows
tmpDbl = tmpDbl + tmpRng(r, 1) * WorksheetFunction.SumSq(tmpRng(r, 3), tmpRng(r, 5))
Next r
End Select
Next i
If IsCase2 Then
CalculateStuff2 = tmpDbl / divisor
Else
CalculateStuff2 = tmpDbl
End If
End Function
Related
Numeric data is streamed into cells B8, B10, B12, B14, B16 and B18 (see below).
Cell B23 is the maximum of the absolute value of the above cells at any time, so the formula in B23 is :
=MAX(ABS($B$8),ABS($B$10),ABS($B$12),ABS($B$14),ABS($B$16),ABS($B$18))
Cell B5 is a user-defined constant, in our case 13.00, and is the threshold value that will trigger one of the macros.
So, in the case below, B23 = 8.00, and because 8.00 < 13.00 no macro is called.
If, however, B5 was 7.50, then since B23 (8.00) >= 7.50, and B14 is a positive value, Macro_7 is to be called. Had B14 been -8.00, then Macro_8 is to be called.
This process is to be started when the user presses the START button, which has macro START assigned to it. Once a macro is called, the process ends till the user restarts it.
I am having trouble coding this in VBA and would appreciate any assistance.
Please try this function.
Function AbsoluteMaximum(RowNum As Long, _
Sign As Long) As Double
Dim AbsMax As Double ' variables range
Dim Tmp As Double ' temporary value
Dim R As Long ' row number
Dim i As Integer ' loop counter: iterations
R = RowNum
RowNum = 0 ' return 0 in case of failure
For i = 1 To 6 ' number of cells
Tmp = Cells(R, "B").Value
If Abs(Tmp) > AbsMax Then
AbsMax = Abs(Tmp)
Sign = Sgn(Tmp)
RowNum = R
End If
R = R + 2
Next i
AbsoluteMaximum = AbsMax
End Function
It returns 3 values: the absolute maximum, the row number where it was found and its Sign. The Sgn() function returns 1 for a positive number, -1 for a negative number and 0 for zero.
This is how you can call the function from VBA.
Sub Test_AbsMax()
Dim RowNum As Long
Dim Sign As Long
Dim AbsMax As Double
RowNum = 8 ' start row: change to suit
AbsMax = AbsoluteMaximum(RowNum, Sign)
MsgBox "Absolute Max = " & AbsMax & vbCr & _
"Sign = " & Sign & vbCr & _
"in row number " & RowNum
End Sub
You can use the Sign variable with code like
Clm = Iif(Sign < 0, 3, 1), specifying columns A or C to link to a button.
Observe that RowNum is the first row number for your variables when the function is called but changed by the function to become the row number where the maximum was found. Therefore its value is different before and after the function call.
If this number is below the threshold you would call no further macro. Else you would call a macro determined by RowNum and Sign.
Try this
Sub RunMacro()
Dim rng As Range
Dim dThreshold As Double
Dim i As Long
Dim dValue As Double
Dim dRunningMin As Double: dRunningMin = 1E+20
Dim lIndex As Long
' Change the sheet name
With ThisWorkbook.Sheets("Sheet2")
Set rng = .Range("B8:B18")
dThreshold = .Range("B5")
lIndex = 0
For i = 1 To rng.Rows.Count Step 2
dValue = rng.Cells(i, 1).Value
If Abs(dValue) >= dThreshold Then
If Abs(dValue) - dThreshold < dRunningMin Then
dRunningMin = Abs(dValue) - dThreshold
lIndex = i + IIf(dValue < 0, 1, 0)
End If
End If
Next i
If lIndex > 0 Then
Application.Run "Macro_" & lIndex
End If
End With
End Sub
The code above will work out the number whose absolute value is greater than the threshold and is nearest to it.
e.g.
Threshold Macro
13 None
7.5 Macro_7
4 Macro_3 (but not Macro_10)
3.1 Macro_6
3 Macro_11
2 Macro_1
If, however, you want to run all macros for numbers whose absolute values are greater than the threshold then you need something like this:
Sub RunMacros()
Dim rng As Range
Dim dThreshold As Double
Dim i As Long
Dim dValue As Double
' Change the sheet name
With ThisWorkbook.Sheets("Sheet2")
Set rng = .Range("B8:B18")
dThreshold = .Range("B5")
For i = 1 To rng.Rows.Count Step 2
dValue = rng.Cells(i, 1).Value
If Abs(dValue) >= dThreshold Then
Application.Run "Macro_" & i + IIf(dValue < 0, 1, 0)
End If
Next i
End With
End Sub
e.g.
Threshold Macro
13 None
7.5 Macro_7
4 Macro_3, Macro_7 and Macro_10
3.1 Macro_3, Macro_6, Macro_7, Macro_10
3 Macro_3, Macro_6, Macro_7, Macro_10, Macro_11
2 Macro_1, Macro_3, Macro_6, Macro_7, Macro_10, Macro_11
Please help.
I'm trying to create a user defined function that will use an array as multiple criteria (Pedigree) to check for corresponding parents (Parent) and then sum their respective ranges (Sumrange).
I've managed to create code that will check if a parent is in the pedigree range which will then return a result of 1 or 0. This will not return true values if blanks verify blanks. I intend to create an array with these 1's and 0's to then SumProduct it with my Sumrange. My problem is that I am unable create an array of these 1's and 0's and SumProduct them with the Sumrange without returning a #value.
This below code doesn't include the SumProduct portion but just returns 1 or 0 based on the criteria.
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Long
Application.Volatile
Dim i As Variant
Dim j As Variant
Dim result As Integer
result = 0
For Each i In Parent
For Each j In Pedigree
If i.Value = "" Or j.Value = "" Then
result = result
ElseIf i.Value = j.Value Then
result = 1: GoTo NextIteration
End If
Next j
NextIteration:
Next i
ProdIf = result
End Function
Thanks for you help.
Thanks to Super Symmetry for getting this 99% of the way there.
Since the original code returned a 1 or 0, I changed the code to provide a sumproduct.
Also I've made the PedigreeRange loop through columns instead of rows to fit the way my Pedigree data is.
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Variant
Application.Volatile
Dim i As Long
Dim j As Long
Dim result() As Variant
ReDim result(1, 1 To Parent.Rows.Count)
Dim x As Long
For i = 1 To Parent.Rows.Count
x = 0
result(1, i) = x
For j = 1 To Pedigree.Columns.Count
If Parent.Cells(i, 1).Value <> "" And Pedigree.Cells(1, j) <> "" And Parent.Cells(i, 1) = Pedigree.Cells(1, j) Then
x = 1
Exit For
End If
Next j
result(1, i) = x * Sumrange(i, 1).Value
Next i
ProdIfs = WorksheetFunction.Sum(result)
End Function
Thanks again. If there are any improvements that can be made to this please let me know.
Answer changed following comments
If you want to return an array, you actually have to create and populate an array in your function and make sure the return type is Variant.
Try this
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Variant
Application.Volatile
Dim i As Long
Dim j As Long
Dim result() As Integer ' The return value must be an array
ReDim result(1 To Parent.Rows.Count, 1 To 1) ' Assuming Parent is 1 column
For i = 1 To Parent.Rows.Count
result(i, 1) = 0 ' set to 0 by default but always good to do it explicitly
For j = 1 To Pedigree.Rows.Count
If Parent.Cells(i, 1).Value <> "" And Parent.Cells(i, 1) = Pedigree.Cells(j, 1) Then
result(i, 1) = 1
Exit For
End If
Next j
Next i
ProdIfs = result
End Function
Edit: following your answer
You just need to keep a running sum.
To make your code run faster you should read values of these ranges and process them in memory. (It is much faster than asking excel for values in cells).
The return value should be a Double
This feels like a SumIfs ranther than a ProdIfs
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Double
Application.Volatile
Dim i As Long
Dim v As Variant
Dim vParent As Variant: vParent = Parent.Value
Dim vPedigree As Variant: vPedigree = Pedigree.Value
Dim vSumRange As Variant: vSumRange = Sumrange.Value
ProdIfs = 0
For i = 1 To UBound(vParent, 1)
For Each v In vPedigree
If len(v) > 0 And v = vParent(i, 1) Then
ProdIfs = ProdIfs + vSumRange(i, 1)
Exit For
End If
Next v
Next i
End Function
I currently have an excel spreadsheet that when a user clicks Go, it assigns a new random number to the cells in the worksheet. The range value is between 1 and 500 in a 20 by 25 matrix. I want to randomly select and change the background color to red for only one cell every time a user clicks the 'Go' button. Code below is currently assigning random numbers to the cells and selecting and highlighting a random cell. However, when Go is clicked again the previously selected cell is still highlighted along with the newly selected cell. How can I code it to only highlight the newly selected cell when clicking Go?
Public Sub GenerateRandom()
Set MyRange = Range("C4:AA23")
For i = 1 To 500
MyRange.Cells(i) = i
Next
For Each Cell In MyRange
swapcell = 1 + Int(Rnd * 500)
savedValue = Cell.Value
Cell.Value = MyRange.Cells(swapcell).Value
MyRange.Cells(swapcell) = savedValue
Next
With MyRange.Cells(1 + Int(Rnd * 500))
MyRange.Cells(RndBetween(1, 500)).Interior.Color = vbRed
End With
End Sub
Public Function RndBetween(ByVal Low, ByVal High) As Integer
Randomize
RndBetween = Int((High - Low + 1) * Rnd + Low)
End Function
As mentioned above, clearing the range colour before you highlight a cell is the quickest way. But if the background colours of your cells are set to something else then the following should work:
Alternate Solution:
Store the location and colour of the cell to highlight cell, then restore it's original colour on each run. You would declare the location outside the sub so that it doesn't disappear once the sub ends. This would help if your background colours are something else. Problem with this is it only works during an Excel session, if you close and save the location would have been lost, unless you saved it to a hidden sheet = unnecessary complexity for this task.
Dim OriginalCell As Range
Dim OriginalCol
Public Sub GenerateRandom()
Dim myRange As Range
Dim NewCell As Range
Set myRange = Range("C4:AA23")
For i = 1 To 500
myRange.Cells(i) = i
Next
For Each Cell In myRange
swapcell = 1 + Int(Rnd * 500)
savedValue = Cell.Value
Cell.Value = myRange.Cells(swapcell).Value
myRange.Cells(swapcell) = savedValue
Next
''''new code
Set NewCell = myRange.Cells(RndBetween(1, MyRange.Cells.Count))
If OriginalCell Is Nothing Then
Set OriginalCell = NewCell
OriginalCol = OriginalCell.Interior.Color
Else
OriginalCell.Interior.Color = OriginalCol
Set OriginalCell = NewCell
OriginalCol = OriginalCell.Interior.Color
End If
NewCell.Interior.Color = vbRed
'''''
End Sub
On a side note, sending ranges to array and working with the array is much faster, but that's another topic. Hope this helps!
Clear the color of the range before setting the color of the random cell:
Public Sub GenerateRandom()
Set Myrange = Range("C4:AA23")
For i = 1 To 500
Myrange.Cells(i) = i
Next
For Each Cell In Myrange
swapcell = 1 + Int(Rnd * 500)
savedValue = Cell.Value
Cell.Value = Myrange.Cells(swapcell).Value
Myrange.Cells(swapcell) = savedValue
Next
Myrange.Interior.Color = xlNone
With Myrange.Cells(1 + Int(Rnd * 500))
Myrange.Cells(RndBetween(1, 500)).Interior.Color = vbRed
End With
End Sub
Public Function RndBetween(ByVal Low, ByVal High) As Integer
Randomize
RndBetween = Int((High - Low + 1) * Rnd + Low)
End Function
The Color question has been answered. But there are other issues in your code, notably that your shuffle is biased, as explained here
Here's a version that fixes the Modulo Bias mentioned in the link, together with a number of other issues
Public Sub GenerateRandom()
'declare variables
Dim MyRange As Range, Cell As Range
Dim i As Long
Dim swapcell As Long, savedValue As Long
Dim idx As Long
Randomize 'only need this once
Set MyRange = ActiveSheet.Range("C4:AA23") 'or specify a specific sheet
For i = 1 To MyRange.Cells.Count ' link size to specified range
MyRange.Cells(i) = i
Next
For idx = MyRange.Cells.Count To 1 Step -1
swapcell = RndBetween(1, idx) 'remove modulo bias
savedValue = MyRange.Cells(idx).Value
MyRange.Cells(idx).Value = MyRange.Cells(swapcell).Value
MyRange.Cells(swapcell) = savedValue
Next
MyRange.Interior.Color = xlNone 'remove colour
'removed unused With block
MyRange.Cells(RndBetween(1, MyRange.Cells.Count)).Interior.Color = vbRed
End Sub
'declare types
Public Function RndBetween(ByVal Low As Long, ByVal High As Long) As Long
RndBetween = Int((High - Low + 1) * Rnd + Low)
End Function
The following code is not working. I get a 2042 error for my VLOOKUP function, however whatever I do I cannot solve it. I have been using if ISERROR and it still does not catch it properly compromising my whole macro. If I run a local window you can see that the value to search for being stored in array "arr" if not found in the "target" range return a 2042 even for subsequent entries.
Sub test()
ThisWorkbook.Activate
Worksheets.add
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
Dim Search_Array As Variant
Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for
Dim Target_MatchValue As Integer
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
counter = 0
n = 0
Target_MatchValue = 0
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1
Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9))
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
If IsError(arr) Then
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = "N/A"
Else
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
End If
Target_Range.Select
If Target_MatchValue = 0 Then
n = n + 1
ElseIf Target_MatchValue > 0 Then
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
SOLUTION
Sub test()
Dim Search_Array As Variant
Dim Target_MatchValue As Variant
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
'data must be ordered in order to apply the non-repetitive condition
Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for
n = 0
With ActiveSheet
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'The problem was here. "A1:T110" did not allowed to the shifting range to change. Now this code will return the value used for the shifting range
Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'target_range.select Activate this code in order to see the macro in action
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces
If IsError(arr) Then
.Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere
Else
.Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2) 'Return the value of the search_array in this cell so to match column A values with column D values if they are found
End If
If IsError(arr) Then
n = n
ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
n = n + 1
ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
Declare your Target_MatchValue As Variant so no errors will be raised, instead you will have to handle what do you want to do when IsError(Target_MatchValue) (when no matches are found)
I've been using =ROWS(my_range)*COLUMNS(my_range) to count the total number of cells within a single column.
I'm now trying to count the total number of cells across a range that contains (unavoidably) merged cells and I'm getting a #REF error using the above formula.
I've also tried: =COUNTA(my_range) & "/" & COUNTA(my_range) + COUNTBLANK(my_range) which is giving me a #VALUE! error.
In my last attempted I hoped that =ROWS(my_range) might work as I've only got merged columns, not merged rows. However this is giving me a #REF error. `
All I need is the total number of cells that exists within my_range
Thank you
So using merged cells make it really annoying to work with a lot of formulas, so I wrote a VBA solution using Arrays:
First this function will go through the range and each time it recognizes a merged cell, the code will add the cells to an Array.
Later when the loop comes to a cell marked as "merged" (= is in the array), the count will skip it (thanks to this topic: Check if a value is in an array or not with Excel VBA).
Option Explicit
Function CountCells(RA As Range) As Long
Application.Volatile
Dim i As Long
Dim a As Long
Dim i2 As Long
Dim a2 As Long
Dim RowCount As Long
Dim ColCount As Long
Dim k As Long
Dim R1 As Long
Dim R2 As Long
Dim C1 As Long
Dim C2 As Long
ReDim iArray(1 To 1) As Variant
R1 = RA.Row
R2 = R1 + RA.Rows.Count - 1
C1 = RA.Column
C2 = C1 + RA.Columns.Count - 1
k = 0
For i = R1 To R2
For a = C1 To C2
If IsInArray(Cells(i, a).Address, iArray) Then
GoTo next_a
End If
ColCount = Cells(i, a).MergeArea.Columns.Count
RowCount = Cells(i, a).MergeArea.Rows.Count
If RowCount > 1 Or ColCount > 1 Then
k = k + RowCount * ColCount - 1
For i2 = i To i + RowCount - 1
For a2 = a To a + ColCount - 1
iArray(UBound(iArray)) = Cells(i2, a2).Address
ReDim Preserve iArray(1 To UBound(iArray) + 1) As Variant
Next a2
Next i2
End If
next_a:
Next a
Next i
CountCells = (R2 + 1 - R1) * (C2 + 1 - C1) - k
End Function
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Application.Volatile
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Then you just need to use this function like this in your sheet:
=countcells(my_range)
or any other range instead of your range named my_range
Note: With Application.Volatile the function updates automatically, but only when you update the sheet with numbers but just not directly when you merge or unmerge cells.