VBA UDF evaluates after every change - excel

I have an issue, I thought would be a pretty simple one, but now can't handle it so I guess was wrong.
I have a UDF that calculates the average of exchange rates between 2 dates
Option Explicit
Public Function averageFromRange() As Double
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Exchange Rates")
Dim dateStart As Date: dateStart = sh.range("G1").Value
Dim dateEnd As Date: dateEnd = sh.range("G2").Value
Dim myRange As String
Dim rangeStart As range
Dim rangeEnd As range
Set rangeStart = sh.range("A:A").Find(What:=CStr(dateStart), LookAt:=xlWhole, LookIn:=xlValues).Offset(0, 1)
Set rangeEnd = sh.range("A:A").Find(What:=CStr(dateEnd), LookAt:=xlWhole, LookIn:=xlValues).Offset(0, 1)
If rangeStart Is Nothing Then
MsgBox ("Date " & dateStart & " out of range")
End If
If rangeEnd Is Nothing Then
MsgBox ("Date " & dateEnd & " out of range")
End If
If Not (rangeStart Is Nothing Or rangeEnd Is Nothing) Then
myRange = rangeStart.Address & ":" & rangeEnd.Address
averageFromRange = Application.WorksheetFunction.Average(range(myRange))
End If
End Function
Any change in the entire workbook (apart from the sheet in which the function is called) re-evaluates the function to #VALUE!. I tried both parametrizing the UDF to have these dates as input params, and activating the sheet. I have no other ideas how to handle this issue. Could you help me out?

The Function returns #VALUE! when any of the dateStart or dateEnd is not found in column [A:A] because of these lines:
Set rangeStart = sh.range("A:A").Find(What:=CStr(dateStart), LookAt:=xlWhole, LookIn:=xlValues).Offset(0, 1)
Set rangeEnd = sh.range("A:A").Find(What:=CStr(dateEnd), LookAt:=xlWhole, LookIn:=xlValues).Offset(0, 1)
Those lines are trying to set the Offset(0, 1) of Nothing (i.e. Find returns Nothing and the lines are still trying to return the Offset)
Solution: First find the Cell containing the Dates then if the dates are found, set the Offset range.
Also you may want the UDF be Volatile if Column [A:A] or the Dates (start & end) are updated by formulas.
Try this code:
Public Function averageFromRange() As Double
Dim dDateIni As Date, dDateEnd As Date
Dim rINI As Range, rEND As Range
Application.Volatile 'Comment this line is VOLATILE is not required
With ThisWorkbook.Worksheets("Exchange Rates")
dDateIni = .Range("G1").Value
dDateEnd = .Range("G2").Value
With .Columns(1)
Set rINI = .Find(What:=CStr(dDateIni), LookAt:=xlWhole, LookIn:=xlValues)
Set rEND = .Find(What:=CStr(dDateEnd), LookAt:=xlWhole, LookIn:=xlValues)
End With
End With
If rINI Is Nothing Then MsgBox ("Date " & dDateIni & " out of range")
If rEND Is Nothing Then MsgBox ("Date " & dDateEnd & " out of range")
If Not (rINI Is Nothing And rEND Is Nothing) Then
averageFromRange = Application.Average(Range(rINI.Offset(0, 1), rEND.Offset(0, 1)))
End If
End Function
Resources used:
Worksheet.Range,
With statement

Related

Search for specific words and replace each with a corresponding different word?

I need to search through a range.
If 5062 is found change to 3201, 5063 to 3202, and 5084 to 3204.
Dim myRange As Range
Set myRange = Range(Cells(6, 3), Cells(65, 3))
With myRange.Find
.Execute FindText:="5062", ReplaceWith:="3201"
.Execute FindText:="5063", ReplaceWith:="3202"
.Execute FindText:="5084", ReplaceWith:="3204"
End With
End Sub
Here, try this:
Sub ReplaceValues()
Dim SearchReplaceArray
Dim I As Long
Dim RG As Range
Set RG = Range("A1:O34")
'Array Storage: <_Array_First_Row__> <___Second_Row_____>
SearchReplaceArray = [{"5062","5063","5084";"3201","3202","3204"}]
For I = 1 To UBound(SearchReplaceArray, 2)
RG.Replace _
What:=SearchReplaceArray(1, I), _
Replacement:=SearchReplaceArray(2, I), _
LookAt:=xlWhole, _
MatchCase:=True
Next I
End Sub
Very easy to modify for any number of replacements.
Makes replacements very quickly.
Turns this:
Into This:
I speed tested it like this... because curiosity:
Sub TestSpeed()
Dim SearchReplaceArray
Dim I As Long
Dim Start
Dim RG As Range
Set RG = Range("A1:J10000")
Start = Timer
'Array Storage: <_Array_First_Row__> <___Second_Row_____>
SearchReplaceArray = [{"5062","5063","5084";"3201","3202","3204"}]
For I = 1 To UBound(SearchReplaceArray, 2)
RG.Replace _
What:=SearchReplaceArray(1, I), _
Replacement:=SearchReplaceArray(2, I), _
LookAt:=xlWhole, _
MatchCase:=True
Next I
Debug.Print "Completed " & RG.Cells.Count & " replacements in " & Timer - Start & " seconds."
End Sub
Every single cell had one of the three values required to replace.
The debug output was:
Completed 100000 replacements in 3.027344 seconds.
Completed 100000 replacements in 2.976563 seconds.
Completed 100000 replacements in 2.996094 seconds.
Completed 100000 replacements in 2.976563 seconds.
Completed 100000 replacements in 3.070313 seconds.
Not bad.
I have made a loop which searches the range provided in your question for the given values. If the value is the value of a cell in the range, it is replaced with the intended value. Hope this helps!
Sub FindVals()
Dim myRange As Range
Set myRange = Range(Cells(6, 3), Cells(65, 3))
Dim chngVal1 As Integer, chngVal2 As Integer, chngVal3 As Integer
chngVal1 = 3201
chngVal2 = 3202
chngVal3 = 3204
For Each cell In myRange
If cell.Value = 5062 Then cell.Value = chngVal1
If cell.Value = 5063 Then cell.Value = chngVal2
If cell.Value = 5084 Then cell.Value = chngVal3
Next
End Sub

Excel VBA will not locate date

I am working to create an add on style sheet to my company timesheet that will autofill company paid holidays by just the user inserting the dates. I use formulas on the excel timesheets to autofill the dates for the entire year so that I save time doing my bi-weekly payroll form. I have a holiday sheet that I name the holidays and input the date they are observed. The code is supposed to search all worksheets in the workbook until it finds the date for the corresponding holiday and input the number of hours off, the holiday code and name. The code I have written will find any date I insert up to 11/9/2022 and after this date it will not find any further dates. I have tried many things including changing the date column format, using different criteria settings for the .Find and even removing the formula from the date column and actually writing in 11/11/2022 and it is still unable to locate the date while using .Find. Please any help would be appreciated. I have added a few screens and code snippets of what I have so far.
Sub VeteransDay()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Holiday").Range("B9").Value
If Trim(FindString) <> "" Then
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
With ws.UsedRange
Set Rng = .Find(What:=FindString, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not Rng Is Nothing Then
sheetName = ws.Name
Cell_Add = Split(Rng.Address, "$")
ThisCol = Cell_Add(1)
ThisRow = Cell_Add(2)
Worksheets(sheetName).Range("K" & ThisRow).Value = 8
Worksheets(sheetName).Range("K" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("L" & ThisRow).Value = "HD"
Worksheets(sheetName).Range("L" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("M" & ThisRow).Value = Range("A9")
Worksheets(sheetName).Range("M" & ThisRow).Font.Color = vbRed
Exit Sub
End If
End With
End If
Next ws
End If
End Sub
enter image description here
enter image description here
Try this, the search is restricted to the range B1:B37 on each sheet.
Option Explicit
Sub VeteransDay()
Dim ws As Worksheet, ar, r
Dim dt As Date, sName As String, n As Long
Dim arHoliday, lastrow As Long, i As Long
With Sheets("Holiday")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
arHoliday = .Range("A1:B" & lastrow).Value
End With
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
' loop through holidays
For i = 1 To UBound(arHoliday)
dt = arHoliday(i, 2)
r = Application.Match(CDbl(dt), ws.Range("B1:B37").Value2, 0)
If Not IsError(r) Then
'MsgBox ws.Name & " row " & r
With ws.Range("K" & r)
.Value = 8
.Offset(, 1) = "HD"
.Offset(, 2) = arHoliday(i, 1) ' col A
.Resize(, 3).Font.Color = vbRed
n = n + 1
End With
End If
Next
End If
Next ws
MsgBox n & " found for all dates", vbInformation
End Sub

VBA: How to use a variable as an argument in range?

I am trying to replace the argument in a Range with a variable so I can call a sub with different variable.
Example:
sub calc(i, j As String)
.range(i:j)
end sub
sub main()
calc A1, B23
end sub
I want the final result in this case to be
.Range("A1:B23")
But I keep getting errors.
Example code which gets an error:
subscript out of range in:
If DatePart("y", Date) > DatePart("y", Sheets(s).Range(x).Value) Then
s & x are declared as Strings
Please help, thanks!
Please, test and try understanding the next approach:
Sub checDateParts()
Dim sh As Worksheet, rng As Range
Set sh = ActiveSheet
Set rng = rngCalc(sh, "A1", "B23")
MsgBox rng.Address 'returned the created range address
Set rng = rngCalc(sh, "A1")
If IsDate(rng.Value) Then 'check if the value of "A1" cell is date
MsgBox DatePart("y", Date) > DatePart("y", rng.Value)
Else
MsgBox "The value of cell """ & rng.Address & """ is not a date..."
End If
End Sub
Function rngCalc(sh As Worksheet, i As String, Optional j As String) As Range
If j <> "" Then
Set rngCalc = sh.Range(i & ":" & j)
Else
Set rngCalc = sh.Range(i)
End If
End Function
You cannot directly compare a date (today date) with a range containing more cells. You can previously extract the maximum date of the range and make the comparison with this one:
Sub checDatePartsBis()
Dim sh As Worksheet, rng As Range, maxDate As Date
Set sh = ActiveSheet
Set rng = rngCalc(sh, "A1", "B11")
MsgBox rng.Address 'returned the created range address
maxDate = DateValue(Format(WorksheetFunction.Max(rng), "dd.mm.yyyy")) ': Stop
MsgBox "Maximum date in the processed range is """ & maxDate & """ and " & vbCrLf & _
"And today is """ & Date & """."
If DatePart("y", Date) > DatePart("y", maxDate) Then
MsgBox "Yes, it is..."
Else
MsgBox "No, it is not..."
End If
End Sub
You must understand that using DatePart("y", Date) returns the day of the year. If you need/want comparing the years, you should use DatePart("yyyy", Date).
Please, test the above solution and send some feedback.

Range.Find unable to find Timestamp

I think I've tried literally everything including converting the Timestamp back into date using CDate
The code is a test I'm running to get the Range.Find to work in the first place. The file in which i look up the time stamp is formatted as special dd.mm.yyyy hh:mm for example 01.01.2019 00:00 whereas in the formula bar it is 01.01.2019 00:00:00
EDIT : Removed the quotes around sDate, a copy and paste mistake
Sub trial()
Dim r As Range
Dim sDate As String
Dim find As Range
Dim col As Long
Set r = ThisWorkbook.Worksheets("INPUT_WIND").Range("d11")
col = ThisWorkbook.Worksheets("INPUT_WIND").Range("d11").Column
sDate = Format(r.Offset(, -col + 2), "dd.mm.yyyy hh:mm")
Debug.Print sDate
Set find = Workbooks("FINO raw-010119-310819").Worksheets(1).Range("A:A").find(sDate, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchFormat:=True)
If Not find Is Nothing Then
Debug.Print find.Offset(, 1)
Else
MsgBox "nicht gefunden"
End If
End Sub
Try this fix
Sub trial()
Dim r As Range
Dim sDate As String
Dim find As Range
Dim col As Long
Set r = Range("d11")
col = Range("d11").Column
sDate = r.Offset(, -col + 2)
Debug.Print sDate
Set find = Worksheets(1).Range("A:A").find(CDate(sDate), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchFormat:=True)
If Not find Is Nothing Then
Debug.Print find.Offset(, 1)
Else
MsgBox "nicht gefunden"
End If
End Sub

Error capture while using .Find is not identifing error

When .Find does not find a result, I want an error msg. I have used the method that is almost universally recommended online, but it is not working. When a value is not found, nothing happens. There should be a msg box identified the error.
If Not rFoundCell Is Nothing Then
MsgBox "val: " & rValue.Value & " Matching Cell: " & rFoundCell.Address
Cells(Range(rFoundCell.Address).Row, Range(rFoundCell.Address).Column).Select
Else
MsgBox (rValue.Value & " not found.")
GoTo end_search
End If
I've tried the other way as well:
If rFoundCell Is Nothing Then
Display a msg "not found"
else
Keep going.
That didn't work either. What am i missing?
Full code follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim PostRng As Range
Dim PendRng As Range
Dim rValue As Range
Dim lLoop As Long
Dim rFoundCell As Range
Dim INTRng As Range
Set PostRng = Range("g:g")
Set PendRng = Range("k:k")
'"Intersect" will ensure your current cell lies on correct column.
Set INTRng = Intersect(Target, PostRng)
'IF conditions to trigger code.
'This IF confirms only one cell changed. -- I think
If Target.Columns.Count = 1 And Target.Rows.Count = 1 Then
If Not INTRng Is Nothing And LCase(Target.Text) = "y" Then
'This block will return the range & value on the row where "y" or "Y" are entered.
Set rValue = Target.Offset(0, -3) 'Returns value in Col D
If rValue = 0 Or rValue = "" Then Set rValue = Target.Offset(0, -2)
Debug.Print "Target "; Target
Debug.Print "rvalue.value "; rValue.Value
'This will loop through a different column, to find the value identified above, and return its cell address in the other column.
With PendRng
Set rFoundCell = .Cells(1, 1)
For lLoop = 1 To WorksheetFunction.CountIf(.Cells, rValue.Value)
Set rFoundCell = .Find(What:=rValue.Value, _
After:=rFoundCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Debug.Print "rfoundcell " & rFoundCell
If Not rFoundCell Is Nothing Then
MsgBox "val: " & rValue.Value & " Matching Cell: " & rFoundCell.Address
'This will use the cell address identified above to move the active cell to that address.
'Have to convert the address to row/column to use in Cell.Select.
Cells(Range(rFoundCell.Address).Row, Range(rFoundCell.Address).Column).Select
Else
MsgBox (rValue.Value & " not found.")
GoTo end_search
End If
Next lLoop
End With
End If
End If
end_search:
End Sub
Received help w/ this code here:
Execute a subroutine when a user enters a trigger into a cell
I believe that your code is skipping the If statement that generates the error box if there is not a match.
This is due to For lLoop = 1 To WorksheetFunction.CountIf(.Cells, rValue.Value) exiting when there is no matches because it equates to For lLoop = 1 To 0
I moved all of your error message code into an If statement above the lLoop as follows:
If WorksheetFunction.CountIf(.Cells, rValue.Value) = 0 Then
MsgBox (rValue.Value & " not found.")
GoTo end_search
End If

Resources