I am currently writing a jumble of excel code to track a number, items and dates and staff members.
I got to a point where I do a search using a cbobox and variant of letters or names to gather data and place it into a list box showing headers and columns
via the Name Manager i have set up: =OFFSET(NEW_IBO_Tracker!$AA$9,0,0,COUNTA(NEW_IBO_Tracker!$AA$9:$AA$9000),15).
I have set up a basic code to test this and it works. It searches the main data, gathers the (selected search variable eg "an"), then makes a copy of all the names that contain "an" places this into the offset location.
The issue that I am having is that the main code is NOT doing the above
Private Sub cmdGetData_Click()
Dim Crit As Range
Dim FindMe As Range
Dim DataSH As Worksheet
Set DataSH = Sheet4
On Error GoTo errHandler:
Application.ScreenUpdating = False
'///////////////////////////////////////////
'if header is selected add the criteria
If Me.cboHeader.Value <> "All_Columns" Then
If Me.txtSearch = "" Then
DataSH.Range("Y9") = ""
Else
DataSH.Range("Y9") = "*" & Me.txtSearch.Value & "*"
End If
End If
'///////////////////////////////////////////
'If all columns is selected
If Me.cboHeader.Value = "All_Columns" Then
'find the value in the column
Set FindMe = DataSH.Range("B9:O100000").Find(What:=txtSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'variable for criteria header
Set Crit = DataSH.Cells(8, FindMe.Column)
'if no criteria is added to the search
If Me.txtSearch = "" Then
DataSH.Range("Y9") = ""
DataSH.Range("Y8") = ""
Else
'add values from the search
DataSH.Range("Y8") = Crit
If Crit = "ID" Then
DataSH.Range("Y9") = Me.txtSearch.Value
Else
DataSH.Range("Y9") = "*" & Me.txtSearch.Value & "*"
End If
'show in the userform the header that is added
Me.txtAllColumn = DataSH.Range("Y8").Value
End If
End If
'/////////////////////////////////////////
'unprotect all sheets
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Unprotect_All
'Filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("NEW_IBO_Tracker!$Y$8:$Y$9"), CopyToRange:=Range("NEW_IBO_Tracker!$AA$8:$AO$8"), _
Unique:=False
'add the dynamic data to the listbox
lstData.RowSource = DataSH.Range("outdata").Address(external:=True)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Protect_All
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'''''''''''''''''''''''''''''''''''''''''''''''''''''Protect all sheets
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Protect_All
'If error occurs then show me exactly where the error occurs
MsgBox "No match found for: " & txtSearch.Text
'clear the listbox if no match is found
Me.lstData.RowSource = ""
Exit Sub
End Sub
I am willing to send the workbook if anyone thinks it would be easier. I have spent about a week trying to get this little bit to work and it's driving me insane OHH YAY!!
Thanks heaps in advance
Related
New to coding so sorry if I'm completely ignoring contexts as I'm still trying to learn them.
I have cells that are trying to pull data from several Pivot Tables in another worksheet. If it is unable to pull any information from the pivot tables, it will return #REF. The Macro is supposed to search through in each cell within several ranges to search for the #REF and replace it with a 0. The reason its several ranges instead of the entire worksheet is that some of the equations are trying to add values from a table and since some of those values are #REF, the sum also ends up being #REF. I need to keep those equations there so once the #REF's are replaced, they would get the sum.
Dim Areas(13) As Range
Set Areas(1) = Range("C5:Z7")
Set Areas(2) = Range("C10:Z14")
Set Areas(3) = Range("C27:Z27")
Set Areas(4) = Range("C33:Z45")
Set Areas(5) = Range("C52:Z55")
Set Areas(6) = Range("C58:Z61")
Set Areas(7) = Range("C63:Z66")
Set Areas(8) = Range("C68:Z72")
Set Areas(9) = Range("C74:Z78")
Set Areas(10) = Range("C80:Z84")
Set Areas(11) = Range("C86:Z90")
Set Areas(12) = Range("C92:Z96")
Set Areas(13) = Range("C102:Z112")
For R = 1 To 13
For Each cell In Areas(R) 'Error: For Each may only iterate over a collection object
If cell.Value = CVErr(xlErrName) Then
.Replace What:="#REF!", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Else
Next
I made a bunch of notes after my code to try to work off of based on other StackOverflow questions which I listed below. I figured they worked will form a single range but I'm working with several. If none of what I did makes sense then disregard the below and help me start over. (Please?) Let me know if you need any more information.
If IsError(cell.Value) Then
' If cell.Value = CVErr(xlErrName) Then
' ...
' End If
'End If
'Dim nm As Name
' For Each nm In ActiveWorkbook.Names
' If InStr(nm.Value, "#REF!") > 0 Then
' nm.Delete
' End If
'Next nm
' ActiveCell.Replace What:="#REF!", Replacement:="0", LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
'With Range("B11:AP55").SpecialCells(xlCellTypeFormulas)
' .Formula = Replace(.Formula, "#REF", "Master", , , vbTextCompare)
'End With
As an alternative to Find, consider SpecialCells
To remove only #REF errors
Sub Demo1()
Dim rng As Range
Dim rErr As Range
Dim cl As Range
With ActiveSheet 'or specify a specific sheet
Set rng = .Range("C5:Z7,C10:Z14,C27:Z27,C33:Z45,C52:Z55,C58:Z61,C63:Z66,C68:Z72,C74:Z78,C80:Z84,C86:Z90,C92:Z96,C102:Z112")
End With
On Error Resume Next
Set rErr = rng.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rErr Is Nothing Then
For Each cl In rErr.Cells
If cl.Value = CVErr(xlErrRef) Then
cl.Offset(0, 1) = 0
End If
Next
End If
End Sub
To remove All errors:
Sub Demo2()
Dim rng As Range
Dim rErr As Range
With ActiveSheet 'or specify a specific sheet
Set rng = .Range("C5:Z7,C10:Z14,C27:Z27,C33:Z45,C52:Z55,C58:Z61,C63:Z66,C68:Z72,C74:Z78,C80:Z84,C86:Z90,C92:Z96,C102:Z112")
End With
On Error Resume Next
Set rErr = rng.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rErr Is Nothing Then
rErr = 0
End If
End Sub
I'm writing a small macro for searching and sorting barcodes.
The idea is that barcodes are scanned into cell C1, then the macro is suppose to count the amount of times the same code is scanned. If the barcode is not already in the list (column B:B) it should add the new barcode in the list (column B:B).
I've managed utilised the Find() syntax, however I can't manage to edit any cells with it. Only thing I am able to do is MsgBox " " Ive tried:
Range("a5").Value = 5
It doesn't work
This is the code I currently have:
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("C1") = "" Then MsgBox "No input"
Dim barcodes As Range
Set barcodes = Range("B:B").Find(What:=Range("C1").Value, After:=Range("B2"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, MatchByte:=True, SearchFormat:=False)
If Not barcodes Is Nothing And Not Range("C1") = "" Then
MsgBox "Found"
End If
If barcodes Is Nothing And Not Range("C1") = "" Then
MsgBox "New product"
End If
End Sub
For MsgBox "Found" I want instead a code that counts the amount of times the same barcode has been scanned in the adjacent cell to the right.
And for Msgbox "New product" I want to write a part that adds the new code to the list in this case Column B:B
The the below will A) verify that you don't have a match (using IsError, which returns boolean) to determine if you need to add a value and start the scan count at 1, or B) if you need to find the previous entry (using Match()) and add to the counter:
If IsError(Application.Match(Cells(1,3).Value,Columns(2),0)) Then
lr = cells(rows.count,2).end(xlup).row
Cells(lr+1,2).Value = Cells(1,3).Value
Cells(lr+1,1).Value = 1
Else
r = Application.match(Cells(1,3).Value,Columns(2),0)
cells(r,1).value = cells(r,1).value + 1
End If
Edit1:
Updated column #s for second subroutine per comment from OP, while stripping out the first subroutine and rewording.
With this code you will need a sheet called "DataBase" where you will store each scan and later will be the source for example for a pivot table:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Barcode As String, i As Long, wsDB As Worksheet, LastRow As Long
Dim DictBarcodes As New Scripting.Dictionary 'You need to check the Microsoft Scripting Runtime reference for this to work
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wsDB = ThisWorkbook.Sheets("DataBase")
With Target
If .Range("C1") = vbNullString Then MsgBox "No input"
On Error Resume Next
'loop through all the barcodes and store them into a dictionary
For i = 1 To .Rows.Count
If .Cells(i, 2) = vbNullString Then Exit For 'skip the loop once a blank cell is found
DictBarcodes.Add .Cells(i, 1), i 'this will raise an error if there are duplicates
Next i
'If the value doesn't exist we add it to the list
If Not DictBarcodes.Exists(.Cells(1, 3)) Then
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Cells(LastRow, 2) = .Cells(1, 3)
End If
End With
'Either it exists or not, store it to the data base to keep tracking
With wsDB
.Cells(1, 1) = "Barcode"
.Cells(1, 2) = "Date Scan"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(LastRow, 1) = .Cells(1, 3)
.Cells(LastRow, 2) = Now
End With
'Finally the output on the adjacent cell
Target.Cells(1, 4) = Application.CountIf(wsDB.Range("A:A"), Target.Cells(1, 3))
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
So I've been solving this problem of mine for a couple days already.
Basically, I have multiple green sheets (my source sheets) and one main sheet (master sheet), the problem I'm working on has to do with looping through these green sheets in order to pull certain information from them and put it on certain columns in my master sheet.
Here's the layout of one of these green sheets for better understanding:
https://imgur.com/cayZXUA
I'm sorry for the links, cant add images yet
You can see that these green sheets consist of multiple boxes which can differ in size from sheet to sheet. Some of the values I need to retrieve are fixed in the same cell address for all green sheets so I have no problem getting them to the master sheet. But there are some cases like this:
https://imgur.com/nPYyLbM
Assumption box contains information that I need to lookup and pull it to Main sheet. In essence, this box can take up vertically any space so that address for values of payroll, tax and miscellaneous expenditures changes.
I came up with the idea of giving these boxes in all green sheets name "Assumptions" like seen in the image above. So the questions is how do I lookup 3rd column of this named box and pull it to main sheet?
Here's Main sheet structure:
https://imgur.com/CWMpGvH
My code so far:
Sub CombiningSheets()
Dim p_value, cst_value, m_value As Long
Dim p, cst, m As String
p = "payroll"
cst = "consolidated social tax"
m = "miscellaneous expenditures"
With ThisWorkbook.Sheets("Main")
For Each wsheet In ThisWorkbook.Sheets
If wsheet.Name <> "Main" Then
Set nextEntry = .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
Set nextEntry_FTE_quantity = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)
Set nextEntry_nonrecurring_expenses = .Cells(.Rows.Count, "S").End(xlUp).Offset(1, 0)
Set nextEntry_initiative_type = .Cells(.Rows.Count, "Q").End(xlUp).Offset(1, 0)
Set nextEntry_initiative_description = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
Set nextEntry_economic_benefit = .Cells(.Rows.Count, "AA").End(xlUp).Offset(1, 0)
Set nextEntry_payroll = .Cells(.Rows.Count, "AI").End(xlUp).Offset(1, 0)
Set nextEntry_consolidated_social_tax = .Cells(.Rows.Count, "AJ").End(xlUp).Offset(1, 0)
Set nextEntry_miscellaneous_expenditures = .Cells(.Rows.Count, "AK").End(xlUp).Offset(1, 0)
If IsError(Application.Match(wsheet.Name, .Range("G:G"), 0)) Then
nextEntry.Value = wsheet.Name
nextEntry_initiative_description.Value = wsheet.Range("K6").Value
nextEntry_FTE_quantity.Value = wsheet.Range("BH16").Value
nextEntry_initiative_type.Value = wsheet.Range("K8").Value
nextEntry_nonrecurring_expenses.Value = wsheet.Range("BH17").Value
nextEntry_economic_benefit.Value = wsheet.Range("BH15").Value
End If
End If
Debug.Print wsheet.Name
Next wsheet
End With
End Sub
From your questions it seems that you have defined named ranges. As I'm aware of your question How to copy sheets with certain tab color from one workbook to another? I do believe that you don't have named ranges on your individual sheets.
Below you find some code if you have named ranges (Sub List_NamedRange_Loop).If you don't have named ranges you can create these named ranges on the individual sheets first (Sub Create_NamedRange).
At the end of this post you find a screenshot of the result I got.
Sub List_NamedRange_Loop()
Dim NamedRange As Name
Dim ws As Worksheet
Dim PrDebug As Boolean
Dim iCt As Integer
PrDebug = False ' => Output to Worksheet "Main"
'PrDebug = True ' => Output to Immediate Window (Ctrl-G in VBE)
'List on sheet "main"
If Not (PrDebug) Then
On Error Resume Next
Debug.Print ActiveWorkbook.Name
Sheets("main").Activate
If ActiveSheet.Name <> "main" Then
Worksheets.Add
ActiveSheet.Name = "main"
End If
On Error GoTo 0
Range("A1:D1000").ClearContents
Range("A1").Value = "Sheet Name"
Range("B1").Value = "Named Range"
Range("C1").Value = "RefersTo"
Range("D1").Value = "Value (Direct Reference)"
Range("E1").Value = "Value (Named Reference)"
End If
'We expect all named ranges to be local = defined on the indivdual sheets
'so no need for the below 'workbook loop'
'Loop through each named range in workbook
' For Each namedrange In ActiveWorkbook.Names
' Debug.Print namedrange.Name, namedrange.RefersTo
' Next namedrange
'Loop through each named range scoped to a specific worksheet
iCt = 0
For Each ws In Worksheets
iCt = iCt + 1
If ws.Names.Count > 0 Then
If PrDebug Then
Debug.Print
Debug.Print ws.Name
Else
End If
For Each NamedRange In ws.Names 'Worksheets("Sheet1").Names
If PrDebug Then
Debug.Print ws.Name, NamedRange.Name, NamedRange.RefersTo
Else
iCt = iCt + 1
Range("A1").Offset(iCt, 0).Value = ws.Name
' Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, ws.Name & "!", "")
If InStr(1, NamedRange.Name, "'") Then
Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, "'" & ws.Name & "'!", "")
Else
Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, ws.Name & "!", "")
End If
Range("C1").Offset(iCt, 0).Value = "'" & NamedRange.RefersTo
Range("D1").Offset(iCt, 0).Value = NamedRange.RefersTo
Range("E1").Offset(iCt, 0).Formula = "=" & NamedRange.Name
Range("E1").Offset(iCt, 0).Calculate
End If
Next NamedRange
Else
' iCt = iCt + 1
' Range("A1").Offset(iCt, 0).Value = ws.Name
' Range("B1").Offset(iCt, 0).Value = "NO NAMES DEFINED!"
End If
Next ws
End Sub
If you don't have named ranges you might create them with the code similar to the following:
Sub Create_NamedRange()
Dim ws As Worksheet
Dim foundRange As Range
For Each ws In Worksheets
If ws.Name <> "main" Then
Debug.Print ws.Name
Set foundRange = ws.Cells.Find(What:="payroll", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False)
If Not (foundRange Is Nothing) Then
Debug.Print "Found: "; ws.Name
'offset between AR and BH: 16 columns (https://imgur.com/nPYyLbM)
ws.Names.Add Name:="payroll", RefersTo:=foundRange.Offset(0, 16)
ws.Names.Add Name:="consolidated_social_tax", RefersTo:=foundRange.Offset(1, 16)
ws.Names.Add Name:="miscellaneous_expenditures", RefersTo:=foundRange.Offset(2, 16)
End If
End If
Next ws
End Sub
I would use Range.Find to locate the cells by keywords and return the values adjacent to them.
Sub TestFind()
Dim colOffset As Long
Dim wsheet As Worksheet
colOffset = Columns("BH").Column - Columns("AR").Column - 2 'Two Extra Cells in Merged Range Adjustment
For Each wsheet In ThisWorkbook.Worksheets
If wsheet.Name <> "Main" Then
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR"), "payroll", 0, colOffset)
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR"), "social tax", 0, colOffset)
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR:AT"), "miscellaneous expenditures", 0, colOffset)
End If
Next
End Sub
Function FindValueRelativeToSearch(SearchRange As Range, search As String, rowOffset As Long, colOffset As Long) As Variant
Dim cell As Range
Application.FindFormat.MergeCells = True
With SearchRange
Set cell = .Find(What:=search, After:=.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)
End With
cell.Offset(rowOffset, colOffset).Activate
If cell Is Nothing Then
Debug.Print "Search not found: FindValueRelativeToSearch()", SearchRange.Address(0, 0, xlA1, True), search
Else
FindValueRelativeToSearch = cell.Offset(rowOffset, colOffset).Value
End If
End Function
I have a userform 'AMForm' for students to choose their classes in university.
There are adjacent option buttons for each class so they can select 'yes' or 'no' if they want to enroll in the class e.g. "Mechanical engineering" with 'yes' or 'no' option buttons next to it.
Once they submit their form it records their choices on the spreadsheet 'AMChoices'. This spreadsheet has each class in the above headings, so it fills the cell with 'x' if it has been selected or '-' if not e.g. if 'Mechanical Engineering' option button is selected it fills 'x' underneath this cell.
Each student logs in via a userform "Login Form". I want to automatically fill their User ID, first and last name onto the "AMchoice sheet" that has their choices when they log on. Their information is held in sheet "studentinformation".
How can I code that when they log on, this info (first 3 columns) is extracted from the "studentinformation" sheet and copied into the first 3 columns of "AMChoice" sheet?
I am doing this for multiple users so when the next user logs their choices, I want the next user's information/choices to be filled into the next empty row. I assume I would have to use some sort of HLookup/Vlookup function but I'm not sure?
My login code.
Option Explicit
Private Sub btnLogin_Click()
Dim RowNo As Long
Dim ID As String, PW As String
Dim WS As Worksheet
Dim aCell As Range
On Error GoTo ErrorHandler
'Ensure User ID and password fields are filled
If Len(Trim(txtUser)) = 0 Then
txtUser.SetFocus
MsgBox "Error. UserID cannot be empty."
Exit Sub
End If
If Len(Trim(txtPass)) = 0 Then
txtPass.SetFocus
MsgBox "Error. Password cannot be empty."
Exit Sub
End If
'Set Range Location
Application.ScreenUpdating = False
Set WS = Worksheets("StudentInformation")
ID = LCase(Me.txtUser)
Set aCell = WS.Columns(1).Find(What:=ID, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'If match found
If Not aCell Is Nothing Then
RowNo = aCell.Row
If Me.txtPass = aCell.Offset(, 1) Then
MsgBox "Login Successful."
AMForm.Show
Unload Me
Else
MsgBox "Incorrect UserID or Password. Please try again.", vbOKOnly
End If
'If not found
Else
MsgBox "Incorrect UserID or Password. Please try again.", vbOKOnly
End If
CleanExit:
Set WS = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Err.Description
Resume CleanExit
End Sub
I know basically nothing about user forms, but assuming you have that part figured out I think the following code should do what you need.
Dim xrow As long, ID as long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim arrStudent() as Variant
Set ws1 = Worksheets("StudentInformation")
Set ws2 = Worksheets("AMChoices")
xrow = 1
'once student logs in
'your code to set ID equal to the studentID used to login
xrow = xrow + 1
'Run the code above each time a student logs in.
'This is to keep the data on AMChoices from overlapping.
Application.ScreenUpdating = false
ws1.Activate
for x = 1 To ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
if ID = Cells(x, 1).value Then
ws1.Cells(x, 1).value = arrStudent[0]
ws1.Cells(x, 2).value = arrStudent[1]
ws1.Cells(x, 3).value = arrStudent[2]
ws1.Cells(x, 4).value = arrStudent[3]
'ws1.Cells(x, n).value = arrStudent[n-1]
'do this n times for each column of info you want to copy
else:
end if
next x
ws2.activate
for xcol = 1 to n
ws2.Cells(xrow, xcol).value = arrStudent[xcol - 1]
next xcol
Application.ScreenUpdating = true
Also this is untested so there might be bugs.
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