I am attempting to practice my VBA skills by coding the equivalent of SUMX2MY2 in my own function, mySUMX2MY2 (I realize I could use =SUMPRODUCT but I'm practicing functions). I'm trying to do it by creating two arrays from whatever ranges are selected and squaring the ranges and minus the second squared range. Each time I try in excel, I get the error #VALUE. My guess is the error is with the argument my function is returning but I'm not sure how to fix it.
Sub main()
End Sub
Function mySumX2MY2(n1 As Range, n2 As Range) As Variant
Dim n1Array() As Variant
Dim n2Array() As Variant
Dim total As Variant
Dim i As Integer
Dim aCell As Variant
i = 1
ReDim n1Array(n1.Count)
ReDim n2Array(n2.Count)
For Each aCell In n1
n1Array(i) = aCell.Value
i = i + 1
Next
For Each aCell In n2
n2Array(i) = aCell.Value
i = i + 1
Next
i = 1
For i = 1 To n1.Rows.Count
total = total + (n1Array(i) * n1Array(i) - n2Array(i) * n2Array(i))
i = i + 1
Next
mySumX2MY2 = total
End Function
Related
My Excel worksheet row cells contain a mixed collection of data types -- numbers, alphas, and errors (e.g., #REF!). I want to pass this range to a function which finds the max number only and ignores the alphas and errors. My code:
Public Function getRangeMax(passedRange As range) As Single
'validate entries in passed range as numbers or skip
'return max from validated numbers
Dim i As Integer, arryLength As Integer
Dim arry()
getRangeMax = 0
arry() = passedRange
arryLength = UBound(arry) - LBound(arry)
For i = 0 To arryLength
On Error Resume Next
If arry(i).value > getRangeMax Then
getRangeMax = arry(i).value
End If
Next i
'getRangeMax = Application.Max(passedRange)
End Function
The function call is: =getRangeMax(C35:I35). The data in that particular range of cells is: dB, 456.00, #REF!, 12. I would expect the code to ignore the dB and #REF! entries and return the maximum number, which in this case is 456.00. Instead, the function returns 0.00. What am I doing wrong?
Your code contains multiple errors, all hidden from you by the always active On Error Resume Next
Here's your code refactored to fix the errors and with an alternative type check
Public Function getRangeMax(passedRange As Range) As Double
'validate entries in passed range as numbers or skip
'return max from validated numbers
Dim i As Long, j As Long
Dim item As Variant
Dim arry()
getRangeMax = 0
arry() = passedRange
For i = 1 To UBound(arry, 1)
For j = 1 To UBound(arry, 2)
item = arry(i, j)
If VarType(item) = vbDouble Then
If item > getRangeMax Then
getRangeMax = item
End If
End If
Next j, i
End Function
Note:
Using VarType to test for valid items to process will result in any cells that are Text but look like numbers to be ignored.
Using IsNummeric to test for valid items to process will result in any cells that are Text but look like numbers to be converted to numbers and included in the test.
Try this:
Public Function Rng_Max_Get(rTrg As Range) As Double
Dim aTrg As Variant, vItm As Variant, blTrg As Boolean
aTrg = rTrg.Value2
For Each vItm In aTrg
If IsNumeric(vItm) Then
If vItm <> Empty Then
If blTrg Then
If vItm > Rng_Max_Get Then Rng_Max_Get = vItm
Else
blTrg = True
Rng_Max_Get = vItm
End If: End If: End If: Next
End Function
Since you are inputting a rectangular Range, you can use the .Rows.Count and .Columns.Count instead of deriving from UBound. Try this:
Option Explicit
Function getRangeMax(passedRange As Range) As Double
'validate entries in passed range as numbers or skip
'return max from validated numbers
Dim lRows As Long, lCols As Long, lR As Long, lC As Long
Dim uValue As Double, uMax As Double
Dim arry() As Variant
arry = passedRange
lRows = passedRange.Rows.Count
lCols = passedRange.Columns.Count
uMax = 0
For lR = 1 To lRows
For lC = 1 To lCols
If IsNumeric(arry(lR, lC)) Then
uValue = CDbl(arry(lR, lC))
If uValue > uMax Then uMax = uValue
End If
Next
Next
getRangeMax = uMax
End Function
I am trying to count the number of cells in a range that has the same color as a reference cells, IF the corresponding cell in another range has the correct value criterion. For example:
If (A1 < 350) and (B1 has the same color as a reference cell), then count 1.
Loop over rows 1 to 15
It is essentially the same problem as the question posted here:
http://www.mrexcel.com/forum/excel-questions/58582-countif-multiple-criteria-one-being-interior-color.html
Unfortunately, it seems that the ExtCell.zip file no longer exit. Hence, I could not simply replicate the given solution. I tried to follow the same approach using the SUMPRODUCT function and I wrote a function for comparing cell color, but it did not work. I got the error "A value used in the formula is of the wrong data type." My code is as follow. I am using Excel 2007 on Windows 7. Any help is appreciated. Thanks!
=SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))
The formula above is keyed into a cell. B57:B65 contain some numerical values, while D57:D65 are colored cells. D307 is the reference cell with the correct color.
'' VBA function ColorCompare
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim CallerCols As Long 'find out the number of cells input by the user
'so as to define the correct array size
With Application.Caller
CallerCols = .Column.Count
End With
ReDim TFresponses(1 To CallerCols)
Dim Idx As Long
Idx = 1
For Each rCell In compareCells
If rCell.Interior.ColorIndex = refCell.Interior.ColorIndex Then
TFresponses(Idx) = 1
Idx = Idx + 1
Else
TFresponses(Idx) = 0
Idx = Idx + 1
End If
Next rCell
ColorCompare = TFresponses
End Function
There are a couple of issues in your code
You need to determine the size of compareCells, not the caller cell
You are considering columns, should be Rows (or Rows and Columns for maximum flexability)
There are a few optimisations you can make
Here's a refactored version of your Function
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range, rRw As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim rw As Long, cl As Long
Dim clr As Variant
clr = refCell.Interior.ColorIndex
ReDim TFresponses(1 To compareCells.Rows.Count, 1 To compareCells.Columns.Count)
rw = 1
For Each rRw In compareCells.Rows
cl = 1
For Each rCell In rRw.Cells
If rCell.Interior.ColorIndex = clr Then
TFresponses(rw, cl) = True
End If
cl = cl + 1
Next rCell
rw = rw + 1
Next rRw
ColorCompare = TFresponses
End Function
Note that while this will return a result for any shaped range, to be useful in SumProduct pass it a range either 1 row high or 1 column wide - just as your sample formula does.
Try this (updated for given formula: =SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))):
Sub test()
i = 57
While Not IsEmpty(Cells(i, 1))
If Cells(i, 2) < 350 And Cells(i, 4).Interior.ColorIndex = Cells(307, 4).Interior.ColorIndex Then 'replace with your reference cell
count = count + 1
End If
i = i + 1
Wend
End Sub
I have the following Excel table:
I want to pass the first column as a string, determine the address of the cells called 'LNA' and 'LCAMP', and sum the adjacent cells 'between' those two addresses. My failed code:
Function LNAtoLCAMP(ComponentList) As Single
Dim i As Integer
Dim LBoundAddress As Variant, UBoundAddress As Variant
For i = LBound(ComponentList) To UBound(ComponentList)
If ComponentList(i, 1).Value = "LNA" Then
LBoundAddress = ComponentList(i, 1).Address.Offset(0, 1)
End If
If ComponentList(i, 1).Value = "LCAMP" Then
UBoundAddress = ComponentList(i, 1).Address.Offset(0, 1)
End If
Next
LNAtoLCAMP = Application.WorksheetFunction.Sum(LBoundAddress, ":", UBoundAddress)
End Function
Maybe there's a better way?
Try this:
Function LNAtoLCAMP() As Single
Dim LNA As Range, LCAMP As Range
With Sheets("Sheet1")
Set LNA = .Range("B:B").Find("LNA").Offset(0, 1)
Set LCAMP = .Range("B:B").Find("LCAMP").Offset(0, 1)
If Not LNA Is Nothing And Not LCAMP Is Nothing Then _
LNAtoLCAMP = Evaluate("SUM(" & .Range(LNA, LCAMP).Address & ")")
End With
End Function
Edit2: For your dynamic needs.
Function CONSUM(rng As Range, str1 As String, str2 As String, _
Optional idx As Long = 1) As Variant
Application.Volatile '<~~ autoupdate on cell change, remove otherwise
Dim r1 As Range, r2 As Range
Set r1 = rng.Find(str1, rng(1), , xlWhole)
Set r2 = rng.Find(str2, rng(1), , xlWhole, , xlPrevious)
If Not r1 Is Nothing And Not r2 Is Nothing Then _
CONSUM = Application.Sum(rng.Parent.Range(r1.Offset(0, idx), _
r2.Offset(0, idx))) Else CONSUM = CVErr(xlErrValue)
End Function
In the second function, you can select the range you search and also specify the string you want to search. It returns #VALUE! error if the strings you specify are not found. HTH.
For Edit2 offset is dynamic as well (default at 1). Also this will sum the first instance of the 1st string up to the last instance of the second which was raised by chrisneilsen.
Result:
According to your comment you are calling the function as
=LNAtoLCAMP(B16:B61)
This is not passing an array, it is passing a range (that's a good thing)
Your function, modified:
Function LNAtoLCAMP(ComponentList As Range) As Variant
Dim i As Long
Dim dat As Variant
Dim Sum As Double
Dim LBoundAddress As Long, UBoundAddress As Long
dat = ComponentList.Value
For i = LBound(dat, 1) To UBound(dat, 1)
Select Case dat(i, 1)
Case "LNA", "LCAMP"
If LBoundAddress = 0 Then
LBoundAddress = i
End If
If i > UBoundAddress Then
UBoundAddress = i
End If
End Select
Next
For i = LBoundAddress To UBoundAddress
Sum = Sum + dat(i, 2)
Next
LNAtoLCAMP = Sum
End Function
Call it with both columns in the range
=LNAtoLCAMP(B16:C61)
Note:
I have assumed you want to include hidden rows in the sum, and "Between" includes the rows LNA and LCAMP are on. Both these assumptions are easily modified if required.
I have also assumed you want to sum from the first instance of either string to the last instance of either string. Also easily modified if required.
You could also pass in the search strings to make it more flexable.
You should add error handling, eg if one of the search string is not in the list
If you insist on using an ApplicationFunction then you need quotes.
Also I believe it should be .offset().address (Needs to be flipped)
TESTED WORKING:
Function LNAtoLCAMP(ByVal ComponentList As Range) As Single
Dim LBoundAddress As Range, UBoundAddress As Range
Dim cel As Range
For Each cel In ComponentList
If cel.Value = "LNA" Then
Set LBoundAddress = cel.Offset(0, 1)
End If
If cel.Value = "LCAMP" Then
Set UBoundAddress = cel.Offset(0, 1)
End If
Next cel
LNAtoLCAMP = Application.WorksheetFunction.Sum(Range(LBoundAddress, UBoundAddress))
End Function
One of the most powerful things about VB is ability to loop through objects in a collection WITHOUT referring to the index - for each loop.
I find it very useful only want to remove objects from a collection.
When doing removing objects from a predefined such as rows on a spread sheet the code is simpler if I use indexing and start at the largest and work back to the first. (Step -1 with an iterator) (otherwise requires an offset as the For each moves the enumerator pointer back to the previous object once the active one is deleted)
eg.
For intA = 10 to 1 step -1
' ...
Next
What about when using a For Each | Next
eg.
For each rngCell in Selection.Cells
' ...
Next
How could I loop backwards using the for each loop syntax?
It's not possible to loop backwards using the for each loop syntax.
As an alternative you can use a For i = a To 1 Step -1 loop:
Sub reverseForEach()
Dim i As Long, rng As Range
Set rng = ActiveSheet.Range("A1:B2")
For i = rng.Cells.Count To 1 Step -1
Debug.Print rng.item(i).Address
' Or shorthand rng(i) as the Item property
' is the default property for the Range object.
' Prints: $B$2, $A$2, $B$1, $A$1
Next i
End Sub
This works with all collections that have the Item property. For instance Worksheets, Areas or Shapes.
Note: The order of the loop when using on the Range object is from right to left, then up.
For built in collections (eg a Range) the short answer is: you can't. For user defined collections the answer linked by #VBlades might be useful, although the cost might outweigh the benifit.
One work around is to seperate the identification of items to be removed from the actual removal. Eg, for a range, build up a new range variable using Union, then process that variable, eg delete all the rows in one go. For the Range example, you can also take advantage of the Variant Array method to further speed things up.
Whether or not any of this is useful will depend on your actual use case.
There are other good answers but here's another alternative method of "stepping backwards" through a Range.
Function to Invert Range into Array
This function returns a "backwards Range Array" that can be used with For..Each:
Function ReverseRange(rg As Range) As Range()
Dim arr() As Range, r As Long, c As Long, n As Long
With rg
ReDim arr(1 To .Cells.Count) 'resize Range Array
For r = .Cells(.Rows.Count, 1).Row To .Cells(1, 1).Row Step -1
For c = .Cells(1, .Columns.Count).Column To .Cells(1, 1).Column Step -1
n = n + 1
Set arr(n) = .Worksheet.Cells(r, c) 'set cell in Array
Next c
Next r
End With
ReverseRange = arr 'return Range Array as function result
End Function
Example Usage:
Sub test()
Dim oCell
For Each oCell In ReverseRange(ActiveSheet.Range("E5:A1"))
Debug.Print oCell.Address 'do something here with each cell
Next oCell
End Sub
use a second variable that is set as your wanted counter and use this one in your code
'ex: Loop from n = 19 to 16
For i = 0 To 3
n = 19 - i
'your code here using n as the counter
Next
Only for Range collections. They are more complicated if they have more than 1 Area.
Basically there are two loops, the first one keeps the index of all the cells in an array and the second one creates a union of ranges from back to front
Option Explicit
Private Sub Main()
Dim InvertedRange As Range
Set InvertedRange = InvertRange(Application.Union(ActiveSheet.Range("A1:A2"), _
ActiveSheet.Range("F6:F7"), ActiveSheet.Range("E4:F5"), ActiveSheet.Range("E1")))
Dim ActualRange As Range
For Each ActualRange In InvertedRange
Debug.Print (ActualRange.Address(False, False) & " : " & ActualRange.Value)
Next ActualRange
End Sub
Public Function InvertRange(ByVal rngRange_I As Range) As Range
Dim RangesArray() As Long
ReDim RangesArray(1 To rngRange_I.Count, 1 To rngRange_I.Count)
Dim ActualArea As Range
Dim ActualRange As Range
Dim ArrayIndex As Long
For Each ActualArea In rngRange_I.Areas
For Each ActualRange In ActualArea
ArrayIndex = ArrayIndex + 1
RangesArray(ArrayIndex, 1) = ActualRange.Row
RangesArray(ArrayIndex, 2) = ActualRange.Column
Next ActualRange
Next ActualArea
Dim ActualRow As Long
Dim ActualColumn As Long
ActualRow = RangesArray(UBound(RangesArray, 1), 1)
ActualColumn = RangesArray(UBound(RangesArray, 2), 2)
With rngRange_I.Worksheet
Dim InvertedRange As Range
Set InvertedRange = .Cells(ActualRow, ActualColumn)
For ArrayIndex = UBound(RangesArray, 1) To LBound(RangesArray, 1) Step -1
ActualRow = RangesArray(ArrayIndex, 1)
ActualColumn = RangesArray(ArrayIndex, 2)
Set InvertedRange = Application.Union(InvertedRange, _
.Cells(ActualRow, ActualColumn))
Next ArrayIndex
End With
Set InvertRange = InvertedRange
End Function
You can use a stack (LIFO data structure) for inventing your list and the code would be something like this:
Dim aStack as Object
Set aStack = CreateObject("System.Collections.Stack")
For Each arngCell in Selection.Cells
aStack.Push(arngCell)
Next
While aStack.Count > 0
rngCell = aStack.Pop
' ...
End While
Set stack = Nothing
I want to create a function that calculate cell in a determined range.
When I return the value of the calc to excel I get an #VALUE! error, which means
that the variable types are different.
I tried to use Cint(var) and get the same error.
Here is the code without Cint():
Function CalcTest(Interval As Range) As Integer
Dim x As Integer
Dim y As Integer
x = Interval.Offset(0, 0).Value
y = Interval.Offset(1, 0).Value
CalcTest = x + y
End Function
I already tried:
Function CalcTest(Intervalo As Range) As Integer
CalcTest = Interval.Offset(0, 0).Value + Interval.Offset(1, 0).Value
End Function
And:
Function CalcTest(Interval As Range) As Integer
Dim x As Integer
Dim y As Integer
x = CInt(Interval.Offset(0, 0).Value)
y = CInt(Interval.Offset(1, 0).Value)
CalcTest = x + y
End Function
And Without declarating de function type:
Function CalcTest(Interval As Range)
...
...
End Function
And in Excel I call the function with some range:
=CalcText(A1:A2)
What Am I doing wrong?
#
The big picture:
What I need to do is create a cel in any place that counts de total values
of the $R col for every occurrency of a key value in $N col.
For every time I have "TH" in $N Col, I need do accumulate de $R col value of that
row in a cel.
Same for many others $N Values.
In this sample the value of the accumulated cel for TH in $N is 25.
Tks for the help!!!
You are making this way hard on yourself.
Put this into a cell in row 2 and drag it down:
=SUMIF(N$2:N2,"TH",R$2:R2)
Is this what you are trying?
Public Function CalcTest(rng1 As Range, rng2 As Range) As Variant
On Error GoTo Whoa
CalcTest = rng1.Value + rng2.Value
Exit Function
Whoa:
CalcTest = "Please check the Range Values"
End Function
In an Excel cell, put this formula =CalcText(A1,A2)
You should not simplify your code to something that doesn't fairly represent your question. From your comments and Question.
Function CalcTest(Interval As Range) As Integer
Dim x As Range
CalcTest = 0
For Each x In Interval
If IsNumeric(x) Then
CalcTest = CalcTest + x.Value
End If
Next x
End Function
This will make sure what you are adding up is actually a number.
But as is this will not work any different then the worksheet function:
=Sum(Range)
Simply converting the values to Integer won't work if what you are converting is not converatble. If you pass a Letter to the CInt() function it will just fail.