VBA Function not returning a value - excel

I have an excel VBA Function that needs to count the cells that are coloured, match a specific string and have another cell blank.
I created it in a test workbook using only a small sample of the data where it worked, but now, when I implement in the main workbook, it returns #Value! I suspect there could be an issue with the string being used, but putting a watch on all my variables shows the function is working as expected but it doesn't actually provide the return value.
Here is the code. Any input will be very much appreciated
Function FundInStarted(rSample As Range, rKRM As Range, rColNum As Range, rArea As Range) As Long
Dim rAreaCell As Range
Dim lMatchColor As Long
Dim lCounter As Long
Dim sKRMMatch As String
Dim lColNumOff As Long
lMatchColor = rSample.Interior.Color
sKRMMatch = rKRM.Value2
lColNumOff = rColNum
For Each rAreaCell In rArea
If rAreaCell.Interior.Color = lMatchColor And rAreaCell.Offset(0, -lColNumOff) = sKRMMatch And rAreaCell.Value = "" Then
lCounter = lCounter + 1
End If
Next
FundInStarted = lCounter
End Function

Related

VBA: How do you handle passing Sheet2!A:A through function parameters?

So I'm aware that Sheets2!A:A Refers specifically to the whole of column A within the Sheet 2 workbook.
However, how do you actually process this when it's passed through a function?
Function Function1(cellValue As Variant, cellList As Range) As Variant
Dim cellContent As Variant
Dim list As Range
Dim i As Integer
cellContent = Sheets("Sheet1").Range(CStr(cellValue)).Value2
list = Range(cellList).Value2
For i = 1 To list
If i = cellContent Then
Function1 = "Found"
Else
Function1 = "Unfound"
End If
Next i
End Function
How would you parse Sheets2!A:A so that it uses the sheet specified and then the range of values in A:A.
I'm using a function so therefore it's effectively being passed through by the user as
=#Function1(A2,Sheet2!A:A)
the range is already a range:
Function Function1(cellValue As range, cellList As Range) As Variant
Dim cellContent As Variant
Dim list As Variant
Dim i As Long
cellContent = cellvalue.Value2
list = intersect(cellList.parent.usedrange,celllist).Value2
Function1 = "Unfound"
For i = 1 To ubound(list,1)
If list(i,1) = cellContent Then
Function1 = "Found"
Exit Function
End If
Next i
End Function
But this just reinvents MATCH:
=IF(ISNUMBER(MATCH(A2,Sheet2!A:A,0)),"Found","Unfound")

A function to copy values to an empty cell on VBA according to some conditions

I'm a newbie in the programming world and I'm currently facing a challenge on VBA.
I've built a monthly calendar spreadsheet, and below every day number there is an empty space to be filled depending on some conditions.
I want to fill these spaces with a list of names, depending if the person has the value of Active or not. Another imposed condition is if the date of the calendar is a holliday the cell will remain an empty space, therefore I did a list of hollidays to test this condition.
Here goes the code i made so far:
Sub teste()
line_fill = 5
line_names = 3
column_names = 17
column_active = 18
For i = 6 To 10
Dim values As Worksheets("Planilha1").Cells(5, i))
Dim test As Worksheets("Planilha1").Cells(line_fill - 1, i)
Dim names As Worksheets("Planilha1").Cells(line_names, column_active)
Dim active As Worksheets("Planilha1").Cells(line_names, column_names)
If IsEmpty(test) And test.value <> WorksheetFunction.VLookup(test.value, Sheet1.Range("M4:M100"), 1, False) Then
If names.value = "Ativo" Then
values = active
line_names = line_names + 1
i = i + 1
Next i
End Sub
Image of the spreadsheet
Link to the spreadsheet I'm using
Please try to step through the code with F8 so you understand what I did and try to adjust it to fit your needs.
This is the setup I used to code it:
And this is the code:
Option Explicit
Public Sub CopyValuesInCalendar()
Dim targetSheet As Worksheet
Dim calendarRange As Range
Dim holidaysRange As Range
Dim teamRange As Range
Dim evalDayCell As Range
Dim teamFilteredList As Variant
Dim holidayLastRow As Long
Dim teamLastRow As Long
Dim counter As Long
Set targetSheet = ThisWorkbook.Worksheets("Planilha1")
targetSheet.AutoFilterMode = False
Set calendarRange = targetSheet.Range("D4:J13")
holidayLastRow = targetSheet.Cells(targetSheet.Rows.Count, 12).End(xlUp).Row
teamLastRow = targetSheet.Cells(targetSheet.Rows.Count, 16).End(xlUp).Row
Set holidaysRange = targetSheet.Range("L4:N" & holidayLastRow)
Set teamRange = targetSheet.Range("P3:Q" & teamLastRow)
teamFilteredList = GetActiveTeamMembers(teamRange)
For Each evalDayCell In calendarRange.Cells
If IsNumeric(evalDayCell.Value) And evalDayCell.Value <> vbNullString Then
If Not IsHoliday(evalDayCell.Value, holidaysRange) Then
If counter > UBound(teamFilteredList) Then
counter = 1
Else
counter = counter + 1
End If
evalDayCell.Offset(1, 0).Value = GetTeamMemberName(counter, teamFilteredList)
End If
End If
Next evalDayCell
End Sub
Private Function IsHoliday(ByVal dayNum As Long, ByVal holidayRange As Range) As Boolean
Dim evalCell As Range
For Each evalCell In holidayRange.Columns(1).Cells
If evalCell.Value = dayNum Then
IsHoliday = True
End If
Next evalCell
End Function
Private Function GetActiveTeamMembers(ByVal teamRange As Range) As Variant
Dim evalCell As Range
Dim counter As Long
Dim tempList() As Variant
For Each evalCell In teamRange.Columns(1).Cells
If evalCell.Offset(0, 1).Value = "Ativo" Then
ReDim Preserve tempList(counter)
tempList(counter) = evalCell.Value
counter = counter + 1
End If
Next evalCell
GetActiveTeamMembers = tempList
End Function
Private Function GetTeamMemberName(ByVal counter As Long, ByVal teamFilteredList As Variant) As String
GetTeamMemberName = teamFilteredList(counter - 1)
End Function
Let me know if it helps.

Out of Context and selecting filled in values in a column

I am having 2 issues that I've been trying to solve all day. First off whenever I try to watch any variable no matter what it says in the watches bar. I tried even just setting a variable to equal a number and watching it and it still gave me .
Second I am trying to put all of the values in column B that have a value into an array (TagName) and it is driving me up a wall. This is the point of the for loop. The out of context thing is not helping the case.
Just for reference "ist" was i as a string but then I added the B just to shorten the code.
Don't worry about the extra dims those are for code that is already working
Thank you for your help!
Sub GenTags()
Dim FolderPath As String
Dim OutputFileNum As Integer
Dim TagName(100) As String
Dim i As Long
Dim ist As String
Sheets("Parameters").Activate
For i = 1 To ActiveWorkbook.ActiveSheet.Columns("B").End(xlDown).Row
ist = "B" & CStr(i)
TagName(i) = ActiveWorkbook.Sheets("Parameters").Range(ist)
Next
End Sub
If you only want cells with values, you should probably have that as part of your loop. I think this should work. I also changed the array to be a variant in case you have a mix of string and numbers.
Sub GenTags()
Dim FolderPath As String
Dim OutputFileNum As Integer
Dim TagName(100) As Variant
Dim i As Long, c As Long
Dim ist As String
Sheets("Parameters").Activate
For i = 1 To ActiveWorkbook.ActiveSheet.Columns("B").End(xlDown).Row
If Not IsEmpty(Range("B" & i)) Then
TagName(c) = Range("B" & i).Value
c = c + 1
End If
Next
End Sub
This approach is a little more granular and takes care of empty cells in the column.
It's easy just yo customize the ">>>>" section
Sub GenTags()
Dim FolderPath As String
Dim OutputFileNum As Integer
Dim ist As String
' Define object variables
Dim sourceSheet As Worksheet
Dim paramSheet As Worksheet
Dim sourceRange As Range
Dim cellEval As Range
' Define other variables
Dim sourceSheetName As String
Dim paramSheetName As String
Dim sourceColumn As String
Dim tagName() As Variant
Dim counter As Long ' before i
Dim nonBlankCounter As Long
Dim totalCells As Long
' >>> Customize to fit your needs
sourceSheetName = "Sheet1"
paramSheetName = "Parameters"
sourceColumn = "B"
' Initialize objects - Change sheets names
Set sourceSheet = ThisWorkbook.Worksheets(sourceSheetName)
Set paramSheet = ThisWorkbook.Worksheets(paramSheetName)
Set sourceRange = Application.Union(sourceSheet.Columns(sourceColumn).SpecialCells(xlCellTypeConstants), sourceSheet.Columns(sourceColumn).SpecialCells(xlCellTypeFormulas))
' Get how many items in column b are
totalCells = sourceRange.Cells.Count
' Redimension the array to include all the items
ReDim tagName(totalCells)
' Initilize the counter (for documentation sake)
counter = 0
For Each cellEval In sourceRange
' Add non empty values
If Trim(cellEval.Value) <> vbNullString Then
' Store it in the array
tagName(counter) = cellEval.Value
counter = counter + 1
End If
Next cellEval
' Redim to leave only used items
ReDim Preserve tagName(counter - 1)
End Sub
Let me know if it helps!
Thank you for your responses. Unfortunatley I had to put this project on the back burner until yesterday but I did try both answers and they didn't work. I decided to go a different direction with the entire code and got it working. Thank you for your help and sorry for the late response.

Excel VBA - errors with application.worksheetfunction.match

I'm really losing my mind with this so would appreciate anyone taking the time to help!
I suspect my problems stem from incorrect variable declaration but I haven't been able to work it out.
So why does this test procedure work:
Sub testmatch3()
Dim arr() As Variant
Dim num As Long
Dim searchVal As Variant
Dim i As Long
ReDim arr(1 To 10)
For i = 1 To 10
arr(i) = i
Next i
searchVal = 4
Debug.Print getMatch(searchVal, arr)
End Sub
Function getMatch(valueToMatch As Variant, matchArr As Variant) As Long
getMatch = Application.WorksheetFunction.Match(valueToMatch, matchArr, 0)
End Function
But the following gives me a mismatch error (Type 13):
Sub NewProcedure()
Dim ENVarr As Variant
Dim StageRange As Range
Dim cell As Range
Dim LastRow As Long
Dim i As Long
Dim ConnSheet As Worksheet
Dim tempstring As Variant
Dim arr() As Variant
Set ConnSheet = ThisWorkbook.Sheets("L1 forces")
' Find the last used row in the sheet and define the required ranges
LastRow = ConnSheet.Range("A11").End(xlDown).row
Set StageRange = ConnSheet.Range("H11:H" & LastRow)
' I have a big table of data in the "ENV sheet" which I transfer into a large 2D array
ENVarr = ThisWorkbook.Worksheets("ENV").Range("A6").CurrentRegion
' From the ENVarray, make its second column into a new 1D array
' This new array has an upper bound dimension equal to the number of rows in ENVarr
ReDim arr(LBound(ENVarr, 1) To UBound(ENVarr, 1))
For i = LBound(arr) To UBound(arr)
arr(i) = ENVarr(i, 2)
Next i
tempstring = "1140"
Debug.Print getMatch(tempstring, arr)
End Sub
Function getMatch(valueToMatch As Variant, matchArr As Variant) As Long
getMatch = Application.WorksheetFunction.Match(valueToMatch, matchArr, 0)
End Function
Just to note the value "1140" DEFINITELY exists in arr!
Thanks
I suppose in your sheet is the number 1140 and you try to match the string "1140". Did you try to write
tempstring = 1140
without quotes?
Alternatively: make sure that there is really a string in your excel sheet: ="1140" and it is not only formatted as string. The return value of =TYPE(cell) ('cell' is containing your 1140) has to be 2.

Optional ranges in vba function

I am trying to return the columns count on a range, sometimes I need one range, but, sometimes I need more than one range.
I have put in optional ranges so I can choose multiple ranges. If I reference a range in the function prototype that I have not supplied in the spreadsheet I get the #Value! error.
I need a way to check if the optional ranges are null, void empty etc. so I don't have to reference the range.
This is the VBA Function Prototype:-
Function GetColoumnCount(ARange1 As Range, Optional ARange2 As Range, Optional ARange3 As Range, Optional ARange4 As Range) As Integer
Dim Result As Integer
Result = 0
Result = ARange1.Columns.Count ' This works
Result = ARange1.Columns.Count + ARange2.Columns.Count ' This doesn't work
GetColoumnCount = Result
End Function
In my spreadsheet I have to enter this in a cell for the function to work.
=GetColoumnCount(BC34:BK34, BC35:BD35, BE35:BF35, BG35:BH35)
this defeats the purpose of having optional arguments.
Try it like this
Function GetColoumnCount(ARange1 As Range, Optional ARange2 As Range, Optional ARange3 As Range, Optional ARange4 As Range) As Long
Dim Result As Long
Result = 0
Result = ARange1.Columns.Count ' This works
If Not ARange2 Is Nothing Then
Result = Result + ARange2.Columns.Count
End If
GetColoumnCount = Result
End Function
If you use the ParamArray keyword in the arguments you can supply a variable number of arguments.
Public Function GetColumnCount(ParamArray Ranges() As Variant) As Long
Dim lReturn As Long
Dim i As Long
Dim rResult As Range
Dim rArea As Range
'Loop through the Ranges array supplied by ParamArray
For i = LBound(Ranges) To UBound(Ranges)
'Only work with those array members that are ranges
If TypeName(Ranges(i)) = "Range" Then
'Use Union to combine all the ranges
If rResult Is Nothing Then
Set rResult = Ranges(i)
Else
Set rResult = Application.Union(rResult, Ranges(i))
End If
End If
Next i
'Loop through the Areas and add up the columns
If Not rResult Is Nothing Then
For Each rArea In rResult.Areas
lReturn = lReturn + rArea.Columns.Count
Next rArea
End If
GetColumnCount = lReturn
End Function
To use:
=getcolumncount(E2:K18) = 7
=getcolumncount(D4:L14,N4:P14) =12 (9+3)
=getcolumncount(C7:F15,H7:L15,K7:N15) =11 (omits double counting overlap)

Resources