Error capture while using .Find is not identifing error - excel

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

Related

VBA filtering list using another list

I'm trying to filter the ID in a table, using IDs from another list. However, when I try to do so the macro only filters the first value in the list.
Table Format
Code:
Sub Test()
Dim wb As Workbook
Set wb = ThisWorkbook
ActiveSheet.AutoFilterMode = False
Workbooks.Open "C:\List.xlsx"
Criteria = Worksheets("DataArray").Range("A3:A103")
wb.Activate
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3, Criteria1:=Criteria, Operator:=xlFilterValues
End Sub
The "List" is in another workbook so I need the macro to open it first.
When I try changing the Range to A4:A103 the filter will just use the A4 (first value in the range).
Try the next way, please:
Dim Crit As Variant
Set Crit = Worksheets("DataArray").Range("A3:A103").Value
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3, Criteria1:=Application.Transpose(Crit), Operator:=xlFilterValues
The column list must be transposed on a row. Otherwise, only its first element will be used.
You can do all this by selecting the ranges (directly in the Excel interface). The following code is reusable:
Option Explicit
Public Sub FilterBySelection()
Dim rngFirst As Range
Dim rngSecond As Range
'
'Get Ranges from User Selection
Set rngFirst = GetRangeBySelection("Select range to filter!" _
& vbNewLine & "Please select a single continuous range!" _
& vbNewLine & vbNewLine & "Note that by selecting a single cell, your" _
& " selection will default to the current region for that cell!" _
, "Select Range")
If rngFirst Is Nothing Then Exit Sub
'
Set rngSecond = GetRangeBySelection("Select range containing filtering values!" _
& vbNewLine & "Please select a single continuous range!" _
& vbNewLine & vbNewLine & "Note that by selecting a single cell, your" _
& " selection will default to the current region for that cell!" _
, "Select Range")
If rngSecond Is Nothing Then Exit Sub
'
'Filter first range using values from the second range
Dim arrValues() As Variant: arrValues = rngSecond.Value2
Dim arrCriteria() As Variant
Dim i As Long
Dim v As Variant
'
'Criteria values must be a 1-dimension array
ReDim arrCriteria(0 To rngSecond.Count - 1)
i = 0
For Each v In arrValues
arrCriteria(i) = CStr(v) 'Criteria must be string data type
i = i + 1
Next v
'
'Filter
On Error Resume Next
If rngFirst.ListObject Is Nothing Then
rngFirst.AutoFilter
rngFirst.AutoFilter Field:=1, Criteria1:=arrCriteria, Operator:=xlFilterValues
Else
With rngFirst.ListObject.Range
.AutoFilter Field:=rngFirst.Column - .Column + 1 _
, Criteria1:=arrCriteria, Operator:=xlFilterValues
End With
End If
On Error GoTo 0
End Sub
Public Function GetRangeBySelection(ByVal prompt_ As String, ByVal title_ As String) As Range
Dim rng As Range
'
Do While rng Is Nothing
On Error Resume Next
Set rng = Application.InputBox(Prompt:=prompt_, Title:=title_, Type:=8)
If rng.Cells.Count = 1 Then Set rng = rng.CurrentRegion
On Error GoTo 0
If rng Is Nothing Then Exit Function
'
On Error GoTo ErrorHandler
If rng.Areas.Count > 1 Then
If MsgBox("Your selection contains " & rng.Areas.Count _
& " different ranges!" & vbNewLine & "Please select only 1 " _
& "range!", vbQuestion + vbRetryCancel, "Cancelled") _
<> vbRetry Then Exit Function
Set rng = Nothing
ElseIf rng.Cells.Count = 1 Then
If MsgBox("No region found from selected cell" & vbNewLine _
& "Please select more than 1 cell!", vbQuestion _
+ vbRetryCancel, "Cancelled") <> vbRetry Then Exit Function
Set rng = Nothing
ElseIf rng.Rows.Count = 1 Then
If MsgBox("Please select more than 1 row!", vbQuestion _
+ vbRetryCancel, "Cancelled") <> vbRetry Then Exit Function
Set rng = Nothing
End If
Loop
Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
MsgBox "Try selecting a smaller range next time", vbInformation, "Cancelled"
End Function
Just run the FilterBySelection method
EDIT 1
Or, if you would like to have less restrictions and be able to select multiple ranges for the filtering values then use this instead:
Option Explicit
Public Sub FilterBySelection()
Dim rngFirst As Range
Dim rngSecond As Range
'
'Get Ranges from User Selection
Set rngFirst = GetRangeBySelection("Select range to filter!" _
& vbNewLine & "Please select a single continuous range!" _
, "Select Range", False)
If rngFirst Is Nothing Then Exit Sub
'
Set rngSecond = GetRangeBySelection("Select range(s) containing filtering values!" _
, "Select Range", True)
If rngSecond Is Nothing Then Exit Sub
'
'Filter first range using values from the second range
Dim rng As Range
Dim arrValues() As Variant
Dim arrCriteria() As Variant
Dim i As Long
Dim v As Variant
'
'Criteria values must be a 1-dimension array
i = 0
ReDim arrCriteria(0 To rngSecond.Count - 1)
For Each rng In rngSecond.Areas
If rng.Count = 1 Then
ReDim arrValues(0 To 0)
arrValues(0) = rng.Value2
Else
arrValues = rng.Value2
End If
For Each v In arrValues
arrCriteria(i) = CStr(v) 'Criteria must be string data type
i = i + 1
Next v
Next
'
'Filter
On Error Resume Next
If rngFirst.ListObject Is Nothing Then
rngFirst.AutoFilter
rngFirst.AutoFilter Field:=1, Criteria1:=arrCriteria, Operator:=xlFilterValues
Else
With rngFirst.ListObject.Range
.AutoFilter Field:=rngFirst.Column - .Column + 1 _
, Criteria1:=arrCriteria, Operator:=xlFilterValues
End With
End If
On Error GoTo 0
End Sub
Public Function GetRangeBySelection(ByVal prompt_ As String, ByVal title_ As String _
, allowMultiArea As Boolean) As Range
Dim rng As Range
'
Do While rng Is Nothing
On Error Resume Next
Set rng = Application.InputBox(Prompt:=prompt_, Title:=title_, Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Function
'
On Error GoTo ErrorHandler
If rng.Areas.Count > 1 And Not allowMultiArea Then
If MsgBox("Your selection contains " & rng.Areas.Count _
& " different ranges!" & vbNewLine & "Please select only 1 " _
& "range!", vbQuestion + vbRetryCancel, "Cancelled") _
<> vbRetry Then Exit Function
Set rng = Nothing
End If
Loop
Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
MsgBox "Try selecting a smaller range next time", vbInformation, "Cancelled"
End Function

Filling a specific column based on user inputs and tracking result

I have range of products that are routinely tested every quarter, each product is tested once annually.
I need an excel VBA that prompts the user to input what product was tested and then prompt the user to input in which quarter (e.g. Q1,Q2 etc ) the product was tested. Then in a specific column this information about which quarter the product is tested is displayed and inputted into a cell.
I then want to be able to keep track of this information about which quarter each product was tested every year so for the next test for each product, would like excel to fill the row next to it. Shown below is an visual example of what I'm trying to achieve.
Example of Excel Worksheet
Also attached is the code I have been trying mould to fit my problem.
Dim myValue As Variant
myValue = InputBox("Give me some input")
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = myValue
Application.FindFormat.Clear
' loop through all sheets
For Each sh In ActiveWorkbook.Worksheets
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
Next
End Sub
In your code you have this line to get the product
myValue = InputBox("Give me some input")
Just add another line to get the Quarter
myValue2 = InputBox("Give me some more input")
The search command is working correctly although it could be made more efficient by restricting the search to the first column not the whole sheet.
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
To match the whole string rather than a part change the parameter LookAt:=xlWhole.
If you only have one product that matches the user input then this code can be deleted.
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
The row number is found simply with
rowno = cl.Row
The next part you seem to be having difficulty with is locating the next available
blank column in that row. The VBA is as a user would do by using Ctrl-CursorLeft
from the end column.
colno = ws.range(rowno,Columns.count).End(xlToLeft.Column +1
Since it's very unlikely your sheet will span more 702 years this might be clearer
colno = ws.range("ZZ" & rowno).End(xlToLeft).Column + 1
Now update that cell
wc.cell(rowno,colno) = Value2
Put those components together using sensible variable names, add some validation on what the user is entering, insert some debugging messages at critical points and you should get something like this ;
Sub enterdata()
Const DBUG As Boolean = False ' set to TRUE to see each step
Const YR1COL = 5 'E
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Dim sProduct As String
Dim iRowno As Long, iQu As Integer, iColno As Integer
Dim rng As Range, iLastRow As Long, wsMatch As Worksheet, cellMatch As Range
Dim chances As Integer: chances = 3
LOOP1: ' get valid product
sProduct = InputBox(Title:="Input Product", prompt:="Product is ")
If DBUG Then Debug.Print sProduct
If Len(sProduct) > 0 Then
' search through all sheets
For Each ws In wb.Sheets
iLastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
If DBUG Then Debug.Print ws.Name & " " & iLastRow
' Search col A of sheet using xlWhole for exact match
Set rng = ws.Range("A2:A" & iLastRow) ' avoid header
Set cellMatch = rng.Find( _
What:=sProduct, _
After:=rng.Cells(2, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
' exit on first match
If Not cellMatch Is Nothing Then
Set wsMatch = ws
GoTo LOOP2
End If
Next
Else
Exit Sub
End If
' no match so try again
If cellMatch Is Nothing Then
chances = chances - 1
If chances < 1 Then
MsgBox "Too many tries", vbCritical, "Exiting"
Exit Sub
End If
MsgBox sProduct & " NOT FOUND - " & chances & " tries left", vbExclamation, "Error"
GoTo LOOP1
End If
LOOP2:
iRowno = cellMatch.Row
If DBUG Then Debug.Print wsMatch.Name & " Row = " & iRowno
' determine column
With wsMatch
iColno = .Cells(iRowno, Columns.count).End(xlToLeft).Column + 1
If iColno < YR1COL Then iColno = YR1COL ' start in E
End With
wsMatch.Activate
wsMatch.Cells(iRowno, iColno).Select
If DBUG Then
wsMatch.Cells(iRowno, iColno).Interior.ColorIndex = 6 ' yellow
Debug.Print "Column = " & iColno
End If
If DBUG Then MsgBox "Target cell " & wsMatch.Name & " Row " & iRowno & " Col " & iColno, vbInformation
chances = 3
LOOP3: ' get valid QU
iQu = Application.InputBox(Title:="Input Quarter", prompt:="Test Qu (1-4) for " & sProduct, Type:=1) ' type 1 number
If iQu = 0 Then
GoTo LOOP1
ElseIf iQu > 4 Then
chances = chances - 1
If chances < 1 Then
MsgBox "Too many tries", vbExclamation, "Error"
Exit Sub
End If
MsgBox iQu & " NOT VALID - " & chances & " tries left", vbExclamation, "Error"
GoTo LOOP3
End If
' Update sheet
wsMatch.Cells(iRowno, iColno) = iQu
If DBUG Then wsMatch.Cells(iRowno, iColno).Interior.ColorIndex = 4 ' green
MsgBox "Product=" & sProduct & vbCr _
& wsMatch.Name & " Row=" & iRowno & " Col=" & iColno & " Qu=" & iQu, vbInformation, "Updated"
GoTo LOOP1 ' next product
End Sub

Find specific text and return cell changing the cell's color

I need a button that identifies the cell of the letter "ç" on the column D and change the color of the cell to red.
I've tried this code, but it's not working.
Sub LettersPT()
Dim Rng As Range
Dim cell As Range
Dim MSG, vazio As String
Set Rng = Range(Range("1"), Range("D" & Rows.Count).End(xlUp))
'Columns(2).Interior.ColorIndex = 0
For Each cell In Rng
Set cells = cells.Find(What:="ç", LookIn:=xlFormulas, Lookat _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If WorksheetFunction.CountIf(Rng, cell.Value) > 1 Then
MSG = MSG & cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & ", "
cell.Interior.ColorIndex = 3
End If
If cells Is Nothing Then
Else
MsgBox ("Portuguese letters in " & cells.Address)
End If
End Sub
The error is
"Compile error: Invalid use of property."
Assuming you want to count how many cells that has letter ç and color matched records to visual.
Also assume that you only want to search through column D. Try the below
Dim Rng As Range
Dim cell As Range
Dim MSG As String
Dim vazio As String
Dim i As Long
Set Rng = Range(Range("D1"), Range("D" & Rows.Count).End(xlUp))
For Each cell In Rng
If cell.Value Like "*ç*" Then
cell.Interior.ColorIndex = 3
MSG = MSG & vbNewLine & cell.Address
i = i + 1
End If
Next
If i = 0 Then
MsgBox ("No Portuguese letters found")
Else
MsgBox (i & " Record(s) Found" & vbNewLine & "Portuguese letters in " & MSG)
End If

Match The Nth Instance In Excel

I am using the match function on spreadsheets and the spreadsheets have the same keywords but in different rows, I am attempting to get the row number and to do this I want to use the second instance of a keyword. How would this be done in VBA my current code is
Application.WorksheetFunction.Match("Hello", Range("A1:A100"), 0)
I was thinking about using the Index function, but I am not exactly sure how to use it.
Start the second match just below the first:
Sub dural()
Dim rw As Long
With Application.WorksheetFunction
rw = .Match("Hello", Range("A1:A1000"), 0)
rw = .Match("Hello", Range("A" & (rw + 1) & ":A1000"), 0) + rw
MsgBox rw
End With
End Sub
If you want the Nth match, I would use Find() and a FindNext() loop.
EDIT#1:
Another way to find the Nth instance is to Evaluate() the typical array formula within VBA. For N=3, in the worksheet, the array formula would be:
=SMALL(IF(A1:A1000="Hello",ROW(A1:A1000)),3)
So with VBA:
Sub dural()
Dim rw As Long, N As Long
N = 3
rw = Evaluate("SMALL(IF(A1:A1000=""Hello"",ROW(A1:A1000))," & N & ")")
MsgBox rw
End Sub
Here is a method using Range.Find.
Option Explicit
Sub FindSecond()
Dim rSearch As Range, C As Range
Const sSearchFor As String = "Hello"
Dim sFirstAddress As String
Set rSearch = Range("A1:A100")
With rSearch 'Note that search starts at the bottom
Set C = .Find(what:=sSearchFor, after:=rSearch(.Rows.Count, 1), _
LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If Not C Is Nothing Then
sFirstAddress = C.Address
Set C = .FindNext(C)
If C.Address <> sFirstAddress Then
MsgBox "2nd instance of " & sSearchFor & " on row " & C.Row
Else
MsgBox "Only one instance of " & sSearchFor & " and it is on row " & C.Row
End If
Else
MsgBox "No instance of " & sSearchFor
End If
End With
End Sub
There might be a better way, but this works:
=MATCH("Hello",INDIRECT("A"&(1+MATCH("Hello",A1:A100,0))&":A100"),0)
This would return the index of the second occurrence, by searching for the first occurrence and using that to define the range to search for the next one.

How to make automatic completing the word

My Friends,
I have two sheets (Sheet1 & Sheet2). in sheet2, Column B all the staff names,
and in the sheet1 there is a form to complete, in Cell C3 of it the name of staff is required to be written. what I want to do is "when I write the initial letters of the employee name, I want Excel to give me option names based on Sheet2, Column B. like when we write in Google anything, Google give options.
thanks in Advance for your help.
another idea is use VBA, I've updated the byundt's code.
It's not possible to show immediately the autofill, but you can type some characters and when you play enter the code check the list and if is one match, autofill the data, otherwise ask user if validate the missing name and add it to the list o delete the last value entered.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range
Set targ = Intersect(Target, Range("C:C")) 'Watch the cells in column C
Set sh = Worksheets("registry") 'the sheet2 where you have the list of names
Set rg = sh.Range("A2", "A" & sh.Range("A1").End(xlDown).Row)
If targ Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo errhandler
For Each cel In targ
If Not IsError(cel) Then
If cel <> "" And cel <> " " And Right(cel, 1) <> Chr(10) Then
Set match1 = Nothing
Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False)
If Not match1 Is Nothing Then
Set match2 = rg.FindNext(after:=match1)
If match2.Address = match1.Address Then
cel = match1
Else
cel.Activate
Application.SendKeys ("{F2}")
End If
Else 'No matches found. The value will be added of the end of range list
msg = "The value """ & Target & """ is not in list, " & vbCrLf & "do you whant to add this item??"
response = MsgBox(msg, 4, "Update list")
If response = 6 Then
sh.Range("A" & sh.Range("A1").End(xlDown).Row + 1) = Target
Else
Range(Target.Address) = ""
End If
End If
Else
If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
End If
End If
Next cel
errhandler: Application.EnableEvents = True
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Resources