I have this Excel VBA function:
Function Positives(Rng As Range) As Range
Dim cell As Range, out As Range
For Each cell In Rng
If cell > 0 Then
If Not out Is Nothing Then
Set out = Union(out, cell)
Else
Set out = cell
End If
End If
Next cell
Set Positives = out
End Function
Why doesn't it work well when there are non-sequential positive numbers in Rng range? for example with values 5, 6, 7, -3, 4, 5 but values 5, 6, 7, -3, -4, -5 it works.
Thank you for your cooperation.
There is a limit for excel to display not consecutive range value using array function, see the comparison below
With consecutive range:
When it is not consecutive range
In your VBA code, when the result is in consecutive range, you will have no issue to display in array formula
When the result is not consecutive range, it return #Value as you mention, to solve this problem, one of the method is to change the result to display in string, hope you find it useful :)
Function Positives1(Rng As Range) As String
Dim cell As Range, out As Range, outCell As Range
Dim result As String
For Each cell In Rng.Cells
If cell.Value > 0 Then
If Not out Is Nothing Then
Set out = Union(out, cell)
Else
Set out = cell
End If
End If
Next cell
result = ""
For Each outCell In out.Cells
If result <> "" Then
result = result & "," & outCell.Value
Else
result = outCell.Value
End If
Next
Positives1 = result
End Function
if you want to return multiple values to multiple cells from a UDF to a sheet, you can do this using an array. Note that the best result will be when the dimensions of the call area and the return array match.
Option Explicit
Function Positives(Rng As Range) As Variant
Dim cell As Range, out As Variant, i As Long
ReDim out(1 To Rng.Cells.Count, 1 To 1) ' form the vertical array
For i = 1 To UBound(out, 1)
out(i, 1) = "no value" ' initial fill of the array
Next
i = 0
For Each cell In Rng
If cell > 0 Then
i = i + 1
out(i, 1) = cell
End If
Next cell
Positives = out
End Function
Related
I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub
The goal for this function in to sum specific cells in a range depending on the value and position of other cells in a different range.
Here is an image so it is more clear:
The answer for Column M would be = 2+4+6+9 = 21
The answer for Column P would be = 3+7+10 = 20
There are 20 different "Precio, Precio2, Precio3,..." that are under "Licitante 1, Licitante 2, ..." which is why I used CASES.
Recap, if a cell in column "M" is >0 then the function should select the cell on column "H" which is on the same row, do this for all the cells in said range and add them.
I have this so far:
Function ImporteLic(lic As String)
Dim cell As Range
Dim i As Integer
Select Case lic
Case "Licitante 1"
For Each cell In Range("M13:M50")
If ActiveCell.Value > 0 Then
ActiveCell.Offset(0, -5) = i
End If
Next cell
ImporteLic = worksheetfuntion.Sum(i)
End Select
End Function
I guess i am missing something in the part where all the cells that meet the criteria add up.
Thank you for your help.
There's a ton of issues with the code you posted. Try this and see if works.
Function ImporteLic(lic As String) As Double
With Worksheets("Sheet1") 'change name
Dim col As Long
col = .Rows(1).Find(lic, lookat:=xlWhole).Column
Dim checkRange As Range
Set checkRange = .Range(.Cells(3, col), .Cells(50, col))
Dim sumRange As Range
Set sumRange = .Range("H3:H50")
Dim addEmUp As Double
addEmUp = WorksheetFunction.SumIf(checkRange, ">0", sumRange)
End With
ImporteLic = addEmUp
End Function
I am trying to count the number of colored cells (which also satisfy another condition).
My cells are as follows:
My intention is to count the cells where there is a 'B' and where the adjacent cells are green in color.
I also write a function as follows:
Function CheckColor(rng As Range) As Boolean
If rng.Interior.ColorIndex = 43 Then
CheckColor = True
Else
CheckColor = False
End If
End Function
I then use SUMPRODUCT function as follows:
=SUMPRODUCT(--(V40:V50="B");--CheckColor(W40:W50))
However, I get an error #VALUE!
UPDATE
I have modified my formula as follows:
Function CheckColor(rng As Range) As Variant
Dim arr As Variant
Dim n As Integer
ReDim arr(0 To rng.Count - 1) As Variant
n = 0
For Each cell In rng
If cell.Interior.ColorIndex <> 43 Then
bl = False
Else
bl = True
End If
arr(n) = bl
n = n + 1
Next cell
CheckColor = arr
End Function
And I use the formula as follows:
=SUMPRODUCT((V40:V50="B")*CheckColor(W40:W50))
The answer I get is 6, which is wrong.
The arrays for column ranges are a bit different Variant(1 To 11, 1 To 1)
Function CheckColor(rng As Range)
Dim arr()
ReDim arr(1 To rng.Count, 1 To 1)
' arr = rng.Value2 ' arr Type in the Locals window shows as Variant(1 To 11, 1 To 1)
For i = 1 To rng.Cells.Count
arr(i, 1) = rng.Cells(i, 1).Interior.ColorIndex = 43
Next i
CheckColor = arr
End Function
You can do this without VBA, but you'll need a 'helper' column.
Create a named range with the name CellColour and the formula =GET.CELL(63,Sheet1!$B1)
Using your example (assuming it starts in cell A1), enter this formula in cells C1:C11: =CellColour. By the looks of your screen shot it should return 43 for green.
You can then use this formula to count column A with green in column B:
=COUNTIFS($A$1:$A$11,"B",$C$1:$C$11,43)
Background colour: How to count cells in a range with a value less than another cell in excel?
Font colour: Excel formula to get cell color
Edit, correction
In the function, you give the funtion a range and compare it to a ColorIndex. That means you ask if the whole range have the colorindex not the cells between.
What you do would work if Excel automaticly reference the right cells and compare them to the value, but i wouldn't do that for you.
So there are different ways you actually can manage this. First you do it without vba like Darren Bartrup-Cook meantion, you can do it with a helper column and write it like
=If(V40="B";CheckColor(W40)
And count the with Countif the true values or you write it in VBA but then you need to loop trough the cells one by one like this:
For x = 1 to 50
If Cells(x,10).Value = "b" AND Cells(x,11).ColorIndex = 43 Then
counter = counter + 1
Next x
Endif
I have come across a situation which required me to average the result of an array of Vlookups. I had no idea how to achieve this with formulas and it seemed like nobody else on StackOverflow had any idea either.
So I decided to write a function to do the job for me. Unfortunately it returns the "#VALUE!" error and I have no idea why! The function works fine when tested with a msgbox. I have annotated my code below:
Option Explicit
Public Function AvgVlookup(Target_Array As String, Lookup_Array As String, Column_Index As Long) As Double
Dim Result As Double
Dim Total As Double
Dim Counter As Long
Dim TargetRange As Range
Dim LookupRange As Range
Dim Cell As Range
' Remove Absolute Indicator
Target_Array = Replace(Target_Array, "$", "")
Lookup_Array = Replace(Lookup_Array, "$", "")
' Convert String to Range
Set TargetRange = Range(Left(Target_Array, InStr(1, Target_Array, ":") - 1), Mid(Target_Array, InStr(1, Target_Array, ":") + 1))
Set LookupRange = Range(Left(Lookup_Array, InStr(1, Lookup_Array, ":") - 1), Mid(Lookup_Array, InStr(1, Lookup_Array, ":") + 1))
' Set Variables to 0
Counter = 0
Total = 0
' For each cell in defined array
For Each Cell In TargetRange
' Vlookup the cell and save lookup value to Result variable
Result = Application.WorksheetFunction.vlookup(Cell, LookupRange, Column_Index, "False")
' Update variables used to calculate average
Total = Total + Result
Counter = Counter + 1
Next Cell
' Perform calculation
AvgVlookup = Total / Counter
End Function
Sub test()
MsgBox AvgVlookup("A5:A8", "G5:H8", 2)
End Sub
Any ideas?
Thanks!
Two things:
First, the way you are setting your ranges are a little long, it can be truncated to simply:
Set TargetRange = Range(Target_Array)
No need to parse the strings after removing the $.
Second, you need to put in an error check in case one of the values in the target range is not in the lookup range.
The whole code:
Public Function AvgVlookup(Target_Array As String, Lookup_Array As String, Column_Index As Long) As Double
Dim Total As Double
Dim Counter As Long
Dim TargetRange As Range
Dim LookupRange As Range
Dim Cell As Range
' Remove Absolute Indicator
Target_Array = Replace(Target_Array, "$", "")
Lookup_Array = Replace(Lookup_Array, "$", "")
' Convert String to Range
Set TargetRange = Range(Target_Array)
Set LookupRange = Range(Lookup_Array)
' Set Variables to 0
Counter = 0
Total = 0
' For each cell in defined array
For Each Cell In TargetRange
' Vlookup the cell and save lookup value to Result variable
Dim Result
Result = Application.VLookup(Cell, LookupRange, Column_Index, "False")
If IsNumeric(Result) Then
Total = Total + Result
Counter = Counter + 1
End If
Next Cell
' Perform calculation
AvgVlookup = Total / Counter
End Function
With the above function to call from the worksheet you would need to call it like this: =AvgVlookup("A5:A8", "G5:H8", 2)
But that is not very helpful. If you change your inputs to ranges:
Public Function AvgVlookup(TargetRange As Range, LookupRange As Range, Column_Index As Long) As Double
Dim Result As Double
Dim Total As Double
Dim Counter As Long
Dim Cell As Range
' Set Variables to 0
Counter = 0
Total = 0
' For each cell in defined array
For Each Cell In TargetRange
' Vlookup the cell and save lookup value to Result variable
Dim t
t = Application.VLookup(Cell, LookupRange, Column_Index, "False")
If IsNumeric(t) Then
Total = Total + t
Counter = Counter + 1
End If
Next Cell
' Perform calculation
AvgVlookup = Total / Counter
End Function
Then you would call it simply, =AvgVlookup($A$5:$A$8,$G$5:$H$8,2). This way you can just highlight the correct ranges and it will work. Also less typing trying to convert a string to a range when what you want to enter is a range.
I have 2 worksheets, Main and Return. I have the values in Main and the results in Return. I am trying to find a particular position in an array containing an index value (the data comes from Main sheet) e.g. 10, 20, 40, 50, 60 etc...then take the 5 values above and 5 values below this index including the index value I am searching for and do an average of it returning the average to a cell on the sheet (to the Return sheet), thus doing an average of 11 values. So far I have managed to store the range in the array using:
Public Sub myArray()
Dim myArr() As Variant
Dim R As Long
Dim C As Long
myArr = Range("C6:D1126")
For R = 1 To UBound(myArr, 1)
For C = 1 To UBound(myArr, 2)
Debug.Print myArr(R, C)
Next C
Next R
End Sub
The search/find of value within the array and averaging has left me scratching my head...
Please help...thank you. Help with the code in the array or manipulating the data from the worksheet itself works fine by me :)
Sample file --> http://www.filedropper.com/indexes
You could use this UDF:
Function avrg(indx, rng As Range)
Dim i, minI As Long, maxI As Long
i = Application.Match(indx, rng.Columns(2), 0)
If IsError(i) Then
avrg = CVErr(xlErrNA)
Exit Function
End If
With WorksheetFunction
minI = .Max(1, i - 5)
maxI = .Min(rng.Rows.Count, i + 5)
avrg = .Average(rng.Cells(1, 1).Offset(minI - 1).Resize(maxI - minI + 1))
End With
End Function
This UDF finds first entry of value (say 10 or 20) in Index column (Main sheet) takes 5 values above and 5 below it and returns average of corresponding values of column Value (Main sheet). If you need to take average of values from column Index, change rng.Cells(1, 1) to rng.Cells(1, 2)
Also note at this lines in UDF:
minI = .Max(1, i - 5)
maxI = .Min(rng.Rows.Count, i + 5)
if we can't take 5 values below and 5 values above index i (e.g. if index of target value equals to 2) we take in first case all values from start and in second case all values untill end of range.
Then you can call it either from worksheet: enter this formula in sheet Dash cell C4: =avrg(C3,Main!$C$6:$D$1126) and drag it across.
either from VBA:
Sub test()
Dim rng As Range
Dim rngInd As Range
Dim cell As Range
Set rng = ThisWorkbook.Worksheets("Main").Range("C6:D1126")
Set rngInd = ThisWorkbook.Worksheets("Dash").Range("C3:L3")
For Each cell In rngInd
cell.Offset(1).Value = avrg(cell.Value, rng)
Next cell
End Sub
In both cases function returns #N/A if indx value not found.