I have written a function that checks cell to be crossed out:
Function isCrossedout(myRange As Range)
isCrossedout = myRange.Font.Strikethrough
End Function
and I have a column "A:A" of numbers where I want to sum up crossed out elements only.
Can I insert in any cell the standard function SUMIFS with my user defined function?
When I try this:
someCell.FormulaR1C1 = "=SUMIFS('Page'!RC1:RC1, isCrossedout)"
it returns zero value when the formula applied.
I realize there is a way to use summing such cells in a pure VBA way with a loop, but I want to try to use it with Excel SUMIFS formula.
First, you need isCrossedout to return a boolean array. Font.Strikethrough will not return an array, so use a loop:
Function isCrossedout(ByVal myRange As Range) As Boolean()
Dim arr() As Boolean
ReDim arr(1 To myRange.Rows.Count, 1) ' assumes myRange has one column
Dim cell As Range
For Each cell In myRange
Dim counter As Long
counter = counter + 1
arr(counter, 1) = cell.Font.Strikethrough
Next
isCrossedout = arr
End Function
Next, I'd use SUMPRODUCT, with the double unary -- to coerce the boolean array to an array of ones and zeros.
=SUMPRODUCT(A2:A5*--isCrossedout(A2:A5))
For a version that can handle a multi-column input:
Function isCrossedout(myRange As Range) As Boolean()
Dim arr() As Boolean
ReDim arr(1 To myRange.Rows.Count, 1 To myRange.Columns.Count)
Dim i As Long, j As Long
For i = 1 To myRange.Rows.Count
For j = 1 To myRange.Columns.Count
arr(i, j) = myRange.Cells(i, j).Font.Strikethrough
Next
Next
isCrossedout = arr
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
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.
I have a function that takes a range of values as input (just a column) as well as some threshold. I would like to return a range that is filtered to include all values from the original range that are greater than the threshold. I have the following code:
Public Function FilterGreaterThan(Rng As Range, Limit As Double) As Range
Dim Cell As Range
Dim ResultRange As Range
For Each Cell In Rng
If Abs(Cell.Value) >= Limit Then
If ResultRange Is Nothing Then
Set ResultRange = Cell
Else
Set ResultRange = Union(ResultRange, Cell)
End If
End If
Next
Set FilterGreaterThan = ResultRange
End Function
The issue is that once a number is below the threshold, other numbers after that one that are above the threshold do not get added to the range.
For example:
Threshold - 2
Numbers -
3
4
1
5
It will loop through adding 3 and 4 but 5 will not be added. I end up getting a #value error. But I get no error and it works fine if I only enter the range - 3, 4 or the range - 3, 4, 1.
It's looks like the UDF doesn't like non-contiguous ranges being written back to an array.
One way around it is to re-write the UDF like below. It assumes the output array is only in column but does allow multiple column input.
Option Explicit
Public Function FilterGreaterThan(Rng As Range, Limit As Double) As Variant
Dim Cell As Range
Dim WriteArray() As Variant
Dim i As Long
Dim cellVal As Variant
Dim CountLimit As Long
CountLimit = WorksheetFunction.CountIf(Rng, ">=" & Limit)
ReDim WriteArray(1 To CountLimit, 1 To 1) 'change if more than 1 column
For Each Cell In Rng
cellVal = Cell.Value
If Abs(cellVal) >= Limit Then
i = i + 1 'change if more than 1 column
WriteArray(i, 1) = cellVal 'change if more than 1 column
End If
Next
FilterGreaterThan = WriteArray
End Function
ooo got there first but I've typed it out now so I may as well post it. This version will return as a column vector of the correct size.
If nothing matches then #N/A is returned in a 1 by 1 array (this is consistent with the normal behaviour of an array function when there are insufficient values to fill the array)
edit2: updated function thanks to comments from ooo
Public Function FilterGreaterThan(Rng As Range, Limit As Double) As Variant()
Dim inputCell As Range ' each cell we read from
Dim resultCount As Integer ' number of matching cells found
Dim resultValue() As Variant ' array of cell values
resultCount = 0
ReDim resultValue(1 To 1, 1 To Rng.Cells.Count)
For Each inputCell In Rng
If Abs(inputCell.Value) >= Limit Then
resultCount = resultCount + 1
resultValue(1, resultCount) = inputCell.Value
End If
Next inputCell
' Output array must be two-dimensional and we can only
' ReDim Preserve the last dimension
If (resultCount > 0) Then
ReDim Preserve resultValue(1 To 1, 1 To resultCount)
Else
resultValue(1, 1) = CVErr(xlErrNA)
ReDim Preserve resultValue(1 To 1, 1 To 1)
End If
' Transpose the results to produce a column rather than a row
resultValue = Application.WorksheetFunction.Transpose(resultValue)
FilterGreaterThan = resultValue
End Function
edit: works OK for me with the test values in the comment below:
I'm sure you know this but don't include the { or } characters when entering the array formula - Excel adds them in after you've hit Ctrl-Shift-Enter