I've been down this road before. Match function worked when I was using a single criteria, but I'm not able to use it properly using two criterias.
My current procedure looks on the NR_Qualtrics page to find a match on CaseID and Email. Because the columns for these can be different based on each document I get, I have procedure that identifies the row and returns which range CaseID and Email is in.
The next thing I'm doing in this function is iterating through each of the rows in NonResidential sheet trying to find a match on CaseID and Email. I need the function to return the row that the match was found on and report that in column O. Currently, I'm still stuck trying to find the matching columns. I keep getting Error 2015 and Error 2029 when I'm debugging. I'm sure that the matches exist when I look through it manually. I'm not sure what I'm doing wrong with my procedure. Can you please help?
Sub NonResFindMultipleProviders()
'This function finds any duplicate Case IDs for NR providers where they had surveys
'This function needs to run before NonRes_ChkSurveyRcd
'If there are duplicates, it will indicate that in the Notes Column (N)
'If a duplicate exists, then it must match on Email and CaseID and show the value of Yes-NR_Qualtrics Row XX/No in Survey Recieved (Column O)
Application.ScreenUpdating = False
Dim r, lastRow, rowMatch As Long
Dim colCaseID, colEmail, colResponseID As Long
Dim rngCaseID, rngEmail, rngResponseID As Range
Dim valEmail, valCaseID As String
Dim result As Variant
Dim shtNR As Worksheet
Dim shtQNR As Worksheet
Sheets("NonResidential").Select
lastRow = getLastRow
Range("A2").Select
Set shtNR = ThisWorkbook.Sheets("NonResidential")
Set shtQNR = ThisWorkbook.Sheets("NR_Qualtrics")
colCaseID = FindColHeaderWText("NR_Qualtrics", "ExternalDataReference")
Set rngCaseID = Worksheets("NR_Qualtrics").Columns(colCaseID)
colEmail = FindColHeaderWText("NR_Qualtrics", "EmailAddress")
Set rngEmail = Worksheets("NR_Qualtrics").Columns(colEmail)
'colResponseID = FindColHeaderWText("NR_Qualtrics", "ResponseID")
'Set rngResponseID = Worksheets("NR_Qualtrics").Columns(colResponseID)
'The Notes field(column N) shows the duplicates. Find matches on CaseID AND Email
''Not (IsError(Application.Match(Cells(r, 1).Value, rng, 0))) And
For r = 2 To lastRow
valCaseID = Cells(r, 1).Value 'Column A (1) has CaseIDs
valEmail = Cells(r, 12).Value 'Column L (12) has emails
result = shtNR.Evaluate("MATCH(" & valCaseID & "&" & valEmail & ",rngCaseID&rngEmail,0)")
If (Not IsError(result)) Then 'Mark only if Notes - Column N (13) is marked with a duplicate - Need to put this in next. RN, just evaluate everything
Cells(r, 15).Value = "Yes" 'Column O (14) Survey Recieved marked with Yes
End If
Next r
'Cleanup - Remove the words duplicate
'Columns("N:N").Select
'Selection.Replace What:="Duplicate", Replacement:="", LookAt:=xlWhole, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
Application.ScreenUpdating = True
End Sub
Here's an example that matches based on 3 criteria. Try dropping your ranges and criteria into this:
Sub MatchMultipleCritera()
' Cells containing the values to match
Dim criteria1 As Range, criteria2 As Range, criteria3 As Range
Set criteria1 = Range("A1")
Set criteria2 = Range("B1")
Set criteria3 = Range("C1")
' Ranges containing the values to be checked against the match values above.
Dim rng1 As Range, rng2 As Range, rng3 As Range
Set rng1 = Range("Table1[Item]")
Set rng2 = Range("Table1[Active]")
Set rng3 = Range("Table1[Quanitity2]")
MsgBox "Row " & Evaluate("=MATCH(1,(" & criteria1.Address & "=" & rng1.Address & ")*(" & criteria2.Address & "=" & rng2.Address & ")*(" & criteria3.Address & "=" & rng3.Address & "))")
End Sub
In this example:
Cells A1, B1 and C1 contain the values I am matching.
I am looking in a table (Excel.ListObject) named "Table1" that has columns "Item", "Active" and "Quantity".
rng1 is checked for the value in criteria1, rng2 for criteria2, etc.
The result is the row number.
This is a VBA modification of this ExcelJet article using array formulas. The Evaluate function evaluates formulas as array formulas by default
Related
I have a long list of words I need to compare against.
As an example fruit and vegetables that needs to be stored cold vs warmer:
Cold
strawberries
raspberries
lettuce
Warm(er)
cucumber
bell pepper
tomatoes
I have a sheet with products and need to loop it:
For Each cel In rng
If LCase(cel.Value) Like "*strawberries*" Or LCase(cel.Value) Like "*raspberries*" Or LCase(cel.Value) Like "*lettuce*" Then
msgbox "Cold"
ElseIf LCase(cel.Value) Like "*cucumber*" or LCase(cel.Value) Like "*bell pepper*" or LCase(cel.Value) Like "*tomato*" Then
msgbox "Warmer"
End If
Next cel
Is there any way I could this better? The syntax to test against all products will be very very long.
Could I somehow group/list them and make the syntax easier to maintain?
Example of the workbook:
To demonstrate what I meant with a wildcard match:
Sub Test()
Dim rng As Range, cl As Range
Dim Cold As Variant, Warm As Variant
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4")
Cold = Array("*strawberries*", "*raspberries*", "*lettuce*")
Warm = Array("*cucumber*", "*bell pepper*", "*tomatoes*")
With Application
For Each cl In rng
If .IsNumber(.Match(True, .IsNumber(.Match(Cold, cl, 0)), 0)) Then
'Or: If UBound(Filter(.IsNumber(.Match(Warm, cl, 0)), True)) = 0 Then
MsgBox "Cold"
ElseIf .IsNumber(.Match(True, .IsNumber(.Match(Warm, cl, 0)), 0)) Then
MsgBox "Warm"
End If
Next
End With
End Sub
Alternatively, you could use regular expressions with word-boundaries:
Sub Test()
Dim rng As Range, cl As Range
Dim Cold As String, Warm As String
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4")
Cold = "strawberries|raspberries|lettuce"
Warm = "cucumber|bell pepper|tomatoes"
With CreateObject("vbscript.regexp")
.IgnoreCase = True
For Each cl In rng
.Pattern = "\b" & Cold & "\b"
If .Test(cl) Then
MsgBox "Cold"
Else
.Pattern = "\b" & Warm & "\b"
If .Test(cl) Then MsgBox "Warm"
End If
Next
End With
End Sub
You can also, match both in any case and see if it's supposed to be a combination of warm and cold.
Here is a perfunctory system that would return the information you want from a list of produce.
Sub GetStorageInstruction()
' 187
Dim Veggie As Variant
Dim Storage As String
Dim Txt As String
Veggie = InputBox("Enter name of fruit or vegetable to store:", _
"Get storage instruction")
Veggie = Trim(Veggie)
If Len(Veggie) Then
Storage = StorageInstruction(Veggie)
If Len(Storage) Then
Txt = "Store " & Veggie & " at a " & Storage & " location."
Else
Txt = "Sorry, I couldn't find instructions on" & vbCr & _
"storage of """ & Veggie & """."
End If
MsgBox Txt, vbInformation, "Storage instructions"
End If
End Sub
Private Function StorageInstruction(ByVal Veggie As String) As String
' 187
' return vbNullString if not found
Dim ListRng As Range
Dim Fnd As Range ' found match
Dim C As Long ' column
' here items for "Cold" storage are in column A,
' items for "Cool" storage are in column B
Set ListRng = Range("A:B") ' adjust to suit
Set Fnd = ListRng.Find(Veggie, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not Fnd Is Nothing Then
' the return result is taken from the caption row (row 1)
' of the column in which a match was found
StorageInstruction = Cells(1, Fnd.Column).Value
End If
End Function
"Ordinarily", you wouldn't work with an InputBox because it's too error prone (typos) but with a validation list or combo box that is based on the same lists. But for the moment, if you are concerned about not finding "Bell peppers" (plural), consider either listing "Bell pepper" as well or modify the search to LookAt:=xlPart.
To make the above code work for you immediately, just type "Cold" in A1, "Cool" in B1 and a list of produce under each header. The code will return the header from the column where the item was found.
I see that you have now added a view of your worksheet. That is a much better base. Instead of the produce name, list a number from your columns C or D (whichever is unique), in my columns A and B, and enter that number in the InputBox. Once you implement that system you can modify the returned answer by using the number to VLOOKUP the product name so that the description appears in the answer along with the number you entered.
As an afterthought, the best way for you would probably be to just select the row you are interested in, click a button (or keyboard shortcut) and have the storage instruction pop up. But the presumption here is that you should be able to attach VBA code to your workbook.
No. Correct. I solved that with search for asparagus then search again in the same string for potatoes. But I know there will be false matches. There is no way around it. Let's just say, if there is a handful of false matches is better than looking through the full sheet manually (30-40 000 rows). – Andreas 1 hour ago
Here is an example of what I recommend. Feel free to go with other answers. If there are multiple matches then fill the cell with "Cold/Warm" as mentioend in the code comments below. This way you can simply filter on these and fix them manually.
Basic Preparation to test this
Create a master sheet in the file which has the code. Let's call it MasterList. The reason why we are doing this is so that it is easier to maintain and when you are distributing the code file, the masterlist is easily available. You can do version control on the file so that everyone uses the current version. Let's say the MasterList looks like this.
Let's say the file (as shown in your image) is called MyData.xlsx and the data is in Sheet1. Feel free to change it in the code below. It looks like this
Code
Option Explicit
Sub Sample()
Dim wsThis As Worksheet
'~~> This is the hidden sheet which has your master list in the file
'~~> which has the code
Set wsThis = ThisWorkbook.Sheets("MasterList")
Dim lRow As Long
Dim MasterList As Variant
With wsThis
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
MasterList = .Range("A2:B" & lRow).Value2
End With
Dim wb As Workbook
Dim wsThat As Worksheet
'~~> Change this to the workbook where the data needs to be checked
Set wb = Workbooks.Open("C:\Users\Siddharth Rout\Desktop\MyData.xlsx")
'~~> Change this to the workseet where the data needs to be checked
Set wsThat = wb.Sheets("Sheet1")
Dim rngToProcess As Range
With wsThat
'~~> Find last row in Col E which has names
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
'~~> Identify your range
Set rngToProcess = .Range("E2:E" & lRow)
'~~> Insert a blank column for output
.Columns(6).Insert Shift:=xlToRight
End With
Dim SearchText As String
Dim aCell As Range, bCell As Range
Dim i As Long
'~~> Loop through the masterlist
For i = LBound(MasterList) To UBound(MasterList)
SearchText = MasterList(i, 1)
Set aCell = rngToProcess.Find(What:=SearchText, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Get the Warm - Cold - Warm/Cold Status
aCell.Offset(, 1).Value = GetStatus(MasterList(i, 2), aCell.Offset(, 1).Value)
'~~> Search again for multiple occurences
Do
Set aCell = rngToProcess.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Offset(, 1).Value = GetStatus(MasterList(i, 2), aCell.Offset(, 1).Value)
Else
Exit Do
End If
Loop
End If
Next i
End Sub
'~~> Common function to asign the values
'~~> If there are multiple matches then fill the cell with "Warm/Cold".
'~~> This way you can simply filter on these and fix them manually.
Private Function GetStatus(MasterStatus As Variant, CurrentStatus As String) As String
Dim newStatus As String
If MasterStatus = "Cold" Then
Select Case CurrentStatus
Case "Warm": newStatus = "Warm/Cold"
Case Else: newStatus = MasterStatus
End Select
ElseIf MasterStatus = "Warm" Then
Select Case CurrentStatus
Case "Cold": newStatus = "Warm/Cold"
Case Else: newStatus = MasterStatus
End Select
End If
GetStatus = newStatus
End Function
Output
When you run the above code you get the below output
Here is an alternative to my earlier answer. Install the code below in a standard code module and make some arrangement to call it, perhaps with a keyboard shortcut or even a button on the sheet. Then simply select an item (anywhere in the list, no particular column) and run the code. You don't need to enter anything.
Sub Storage_Instruction()
' 187
Const SKUClm As String = "D" ' change to point at the SKU column in 'Data'
Const DescClm As String = "E" ' change to point at the Description column in 'Data'
Const StgClm As String = "C" ' change to point at Storage Instruction column in WsList
Dim WsData As Worksheet
Dim WsList As Worksheet
Dim SKU As String ' SKU number from row R
Dim Desc As String ' Description from row R
Dim R As Long ' the selected row
Dim LookUpRng As Range ' in WsList
Dim Fnd As Range ' found match
Dim Storage As Variant
Dim Txt As String
Set WsData = Worksheets("Data") ' insert your data sheet's name here
Set WsList = Worksheets("Storage") ' change name to suit
With WsList
' my list has an extra column for 'Description'
' the storage instruction is in column C (=StgClm)
Set LookUpRng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, StgClm).End(xlUp))
End With
If ActiveSheet Is WsData Then
R = Selection.Row
With WsData
SKU = .Cells(R, SKUClm).Value
Desc = .Cells(R, DescClm).Value
End With
Set Fnd = LookUpRng.Find(SKU, LookIn:=xlValues, Lookat:=xlWhole)
If Fnd Is Nothing Then
Txt = "Sorry, I couldn't find instructions for the" & vbCr & _
"storage of " & Desc & "(SKU " & SKU & ")."
Else
Storage = WsList.Cells(Fnd.Row, StgClm).Value
Txt = "Store " & Desc & " (SKU " & SKU & ") at " & String(2, vbCr) & _
String(8, Chr(32)) & UCase(Storage) & String(2, vbCr) & "temperature."
End If
End If
MsgBox Txt, vbInformation, "Storage instruction"
End Sub
For the setup you do need to specify the 3 constants at the top of the procedure and the names of the two worksheets that are referenced.
The list is a simple copy of the SKU column from your big list. In my test I also copied the the descriptions. You may find that way easier to fill the 3rd column, which holds the words "Cool" and "Cold" (or whatever else you want) against each item. The middle column isn't used and not required y the above code.
According to your description, the 'List' sheet should be Very Hidden. In the VB Editor's Project Browser, click on the sheet, bring up its properties and set the Visible property to xlVeryHidden. The sheet can be made visible only by changing this property back to xlVisible. The property setting is saved when you save the workbook.
Here is a sample of the report I have:
Basically the report consists in a huge list of suppliers where among other things, I need to identify which of them have all entities (content groups) for the same country, while ignoring the "integrate" tag. Entities for each country are defined in a table separately (right).
So far I tried a combination of =SUMPRODUCT(--(ISNUMBER(SEARCH())) but always getting partially what I want.
In column C, in need:
to display YES if the supplier on that row has all entities for the mentioned country code;
to display NO otherwise;
My logic on this:
The formula/s needs to pick the country code from 1st table, then look into the 2nd table where entities are defined and check if all the entities in the content group are matching, ignoring "integrate" which is a default tag applied everywhere.
Expected result:
Try:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRowA As Long, i As Long, y As Long
Dim arr As Variant
Dim CountryCode As String
Dim rng As Range, SearchRange As Range, FindPosition As Range
Dim Appears As Boolean
'Set worksheets on variables
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1")
Set ws2 = .Worksheets("Sheet2")
End With
'Set the range to search in for country codes
Set SearchRange = ws2.Range("H1:R1")
With ws1
'Find the last row of Column A sheet1
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
'Start loop from row 2 to last row sheet1
For i = 2 To LastRowA
'Criteria needed ( Column A - Not empty cell, Column D - Includes "Europe" & Column E - Includes "No" Columns D and E are CASE SENSITIVE)
If .Range("A" & i).Value <> "" And .Range("D" & i).Value = "Europe" And .Range("E" & i).Value = "No" Then
CountryCode = .Range("B" & i).Value
'In which column the country code found
Set FindPosition = SearchRange.Find(What:=CountryCode, LookIn:=xlValues, LookAt:=xlWhole)
'If code excist
If Not FindPosition Is Nothing Then
'Set the range to search for the groups in the column where the code is header
Set rng = ws2.Range(ws2.Cells(2, FindPosition.Column), ws2.Cells(ws2.Cells(ws2.Rows.Count, FindPosition.Column).End(xlUp).Row, FindPosition.Column))
'Split the string with comma and assing it on arr
arr = Split(.Range("A" & i).Value)
Appears = False
'Loop the arr
For y = LBound(arr) To UBound(arr)
'Check if the arr(y) start from C as all code start from C
If Left(arr(y), 1) = "C" Then
'Count how many times the arr(y) with out the comma appears in the rng
If Application.WorksheetFunction.CountIf(rng, Replace(arr(y), ",", "")) > 0 Then
'If appears the variable Appears is true
Appears = True
Else
'If does not appear the variable Appears is False & Exit the loop
Appears = False
Exit For
End If
End If
Next y
'Check Appears variable status and import value in Column C
If Appears = True Then
.Range("C" & i).Value = "Yes"
Else
.Range("C" & i).Value = "No"
End If
'If code does not excist
Else: MsgBox "Country Code not does not excist."
End If
End If
Next i
End With
End Sub
If you have a version of Excel 2013+ which has the FILTERXML function, you can use this array formula:
=IF(OR(ISNA(MATCH(FILTERXML("<t><s>"&SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A2,"Integrate",""),", ",","),",","</s><s>")&"</s></t>","//s"),INDIRECT("Table2["&B2&"]"),0))),"No","Yes")
We remove the Integrate
Create an XMLfrom the strings in Table1
Extract each element of the XML
Try to find them in the appropriate column of Table2
If we don't find one, then it has multiple countries.
Since this is an array formula, you need to "confirm" it by holding down ctrl + shift while hitting enter. If you do this correctly, Excel will place braces {...} around the formula as observed in the formula bar
If you have a version of Excel that does not have this function, and you are still interested in using excel formulas as opposed to VBA, there is another formula we can use.
There is a filter applied to my range of data and i would like to search the keyword "abc" in column "I" after the filtering and return a value "Check" at the very end of my data column "W"
I have not know any example to this function but i do had a code before to search for value and delete the row if the amount is 0.
'Delete rows for zero value
Dim LR As Long, i As Long
With Sheets("tempp")
LR = .Cells.Find(What:="0", SearchDirection:=xlPrevious,
SearchOrder:=xlByRows).Row
For i = LR To 1 Step -1
If .Range("C" & i).Value = 0 Then .Rows(i).Delete
Next i
End With
The below code will search your column I. Please adjust the sheet name to your need. It will return the checked status if "abc" is found. If it is not found you can run your desired check where stipulated.
Sub RangeCheck()
Dim myRange As Range
Dim lRowW as Long
'adjust the sheet name to your sheet name
Set myRange = Sheets("Sheet1").Range("I:I").SpecialCells(xlCellTypeVisible).Find(What:="abc")
If Not myRange Is Nothing Then
'found abc, insert checked - presumably the last row of column W?
lRowW = Sheets("Sheet1").Range("W" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
Sheets("Sheet1").Range("W" & lRowW).Value = "Checked"
'if not last row in column W, then use the below
'Sheets("Sheet1").Range("W1").Value = "Checked"
Else
'if it does not find your string "abc" then insert the check you want to run here
End If
'clear object
Set myRange = Nothing
End Sub
You can use something like this:
Dim c As Range
'Going through each visible cell in *I* column. Change 5000 to the numbers of rows your sheet have
For Each c In Worksheets("tempp").Range("I1:I5000").SpecialCells(xlCellTypeVisible)
'Checking if cell contains abc
If InStr(c.Value, "abc") > 0 Then
Worksheets("tempp").Range("W" & c.Row).Value = "Check"
End If
Next
Let us know if it works!
Hello all this is my first question so I will try my best to format this best I can.
Quick description without specific cell names below
I am trying to write a macro where a user enters a value(X) and a macro searches a range of cells for a value(X), and then the macro returns the cell values in the 3 spaces next to wherever the location of value(X) is.
A couple things that are making this impossible to solve are the fact that the user inputs the value on Sheet1 and the value is moved to Sheet2 by a formula, I can't seem to figure out how to use Find where the values I am searching for isn't already defined in the macro.
The other thing making this difficult is that the range is not strictly definable either, as the list could be longer or shorter than it currently is, and I can't know when it will change. So the range of the search has to start based on which List is input by the User and needs to go until it hits a blank spot.
For example: Range.("C7:D10") wont work because the user could enter new info that changes the working range as described below.
Below is a screenshot with further explanation
https://i.stack.imgur.com/wlnhg.jpg
So in this screenshot the cells C3 and D3 are imported values from Sheet1.
C3 is (=Sheet1!B2)
D3 is (=Sheet1!B3)
The idea is that the macro runs and searches down column A till it has a match with C3.
Then the search function moves over two cells and searches down till it has a match with D3 or until it hits an empty space.
I don't know how to ask a macro to search based on an imported value, and I don't know how to ask it to search this weird certain range I need. The idea is that someone at my work could come along and add a row below C10 and add the necessary information and the macro would still work and search to C11 and there would be a blank space after to tell the macro to stop.
After the search finds a match for D3 it would return the values adjacent to the match to the corresponding cells at the top, E3, F3, and G3.
I hope this question is asked in a way that people can understand, I am very tired so can't tell if I wrote something that makes sense. Thank you for reading my post, y'all are the best!!
Search Twice
Workbook Download (Dropbox)
Sub SearchTwice()
Const cSheet As String = "Sheet2" ' Source Worksheet Name
Const cList As String = "C3" ' List Cell Range Address
Const cName As String = "D3" ' Name Cell Range Address
Const cListCol As String = "A" ' List Column Letter
Const cNameCol As String = "C" ' Name Column Letter
Const cFirst As Long = 6 ' First Row
Const cCol As Long = 3 ' Number of Columns
Dim rng1 As Range ' Find List Cell Range
' Found Name Cell Range
Dim rng2 As Range ' Next List Cell Range
' Name Search Range
Dim strList As String ' List
Dim strName As String ' Name
' In Source Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Write from List Cell Range to List.
strList = .Range(cList)
' Write from Name Cell Range to Name.
strName = .Range(cName)
' Check if Cell Ranges do NOT contain data.
If strList = "" Or strName = "" Then ' Inform user.
MsgBox "Missing List or Name.", vbCritical, "Missing data"
Exit Sub
End If
' In List Column
With .Columns(cListCol)
' Create a reference to Find List Cell Range (rng1) containing
' List (strList).
Set rng1 = .Find(strList, .Cells(cFirst - 1), xlValues, xlWhole)
' Check if List has not been found.
If rng1 Is Nothing Then ' Inform user and exit.
MsgBox "The list '" & strList & "' has not been found", _
vbCritical, "List not found"
Exit Sub
End If
' Create a reference to Next List Cell Range (rng2).
Set rng2 = .Find("*", .Cells(rng1.Row), xlValues, xlWhole)
End With
' In Name Column
With .Columns(cNameCol)
' Check if the row of Next List Cell Range (rng2) is greater than
' the row of List Cell Range (rng1) i.e. if a cell with a value
' has been found below List Cell Range (rng1) in List Column.
If rng2.Row > rng1.Row Then ' Next List Cell Range FOUND.
' Create a reference to Name Search Range (rng2) which spans
' from the cell below Find List Cell Range (rng1) to the cell
' above the Next List Cell Range (rng2), but in Name Column.
Set rng2 = .Cells(rng1.Row + 1).Resize(rng2.Row - rng1.Row - 1)
Else ' Next List Cell Range NOT found.
' Create a reference to Name Search Range (rng2) which spans
' from the cell below Find List Cell Range (rng1) to the bottom
' cell, but in Name column.
Set rng2 = .Cells(rng1.Row + 1).Resize(.Rows.Count - rng1.Row)
End If
End With
' In Name Search Range (rng2)
With rng2
' Create a reference to Found Name Cell Range (rng1).
Set rng1 = .Find(strName, .Cells(.Rows.Count), xlValues, xlWhole)
End With
' Check if Name has not been found.
If rng1 Is Nothing Then ' Inform user and exit.
MsgBox "The name '" & strName & "' has not been found", _
vbCritical, "Name not found"
Exit Sub
End If
' Remarks:
' Source Range is calculated by moving the Found Name Cell Range (rng1)
' one cell to the right and by resizing it by Number of Columns (cCol).
' Target Range is calculated by moving the Name Cell Range one cell
' to the right and by resizing it by Number of Columns (cCol).
' Copy values of Source Range to Target Range.
.Range(cName).Offset(, 1).Resize(, cCol) _
= rng1.Offset(, 1).Resize(, cCol).Value
End With
' Inform user of succes of the operation.
MsgBox "The name '" & strName & "' was successfully found in list '" & _
strList & "'. The corresponding data has been written to the " _
& "worksheet.", vbInformation, "Success"
End Sub
One reason for being tired is that you tried to go for the kill before you had set up for slaughter. The solution below took an hour to prepare and 10 minutes to encode. Paste the entire code in a standard code module and call the function MatchRow either from the Immediate window (? MatchRow) or from your own code as shown in the test proc further down.
Option Explicit
Enum Nws ' worksheet navigation
' 01 Mar 2019
NwsCriteriaRow = 3
NwsList = 1 ' Columns: (1 = A)
NwsID = 3
NwsNumber ' (undefined: assigns next integer)
End Enum
Function MatchRow() As Long
' 01 Mar 2019
' return 0 if not found
Dim Ws As Worksheet
Dim Rng As Range
Dim R As Long
' The ActiveWorkbook isn't necessarily ThisWorkbook
Set Ws = ActiveWorkbook.Worksheets("Sheet2") ' replace tab's name here
With Ws
Set Rng = .Range(.Cells(NwsCriteriaRow, NwsList), .Cells(.Rows.Count, NwsList).End(xlUp))
R = FindRow(.Cells(NwsCriteriaRow, NwsID).Value, Rng, True)
If R Then ' skip if no match was found
Set Rng = .Cells(R + 1, NwsID)
Set Rng = .Range(Rng, Rng.End(xlDown))
MatchRow = FindRow(.Cells(NwsCriteriaRow, NwsNumber).Value, Rng)
End If
End With
End Function
Private Function FindRow(Crit As Variant, _
Rng As Range, _
Optional ByVal SearchFromTop As Boolean) As Long
' 01 Mar 2019
' return 0 if not found
Dim Fun As Range
Dim StartCell As Long
With Rng
If SearchFromTop Then
StartCell = 1
Else
StartCell = .Cells.Count
End If
Set Fun = .Find(What:=Crit, _
After:=.Cells(StartCell), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
MatchCase:=False)
End With
If Not Fun Is Nothing Then FindRow = Fun.Row
End Function
The function MatchRow returns the row number of Sheet2 where D3 is found, searching only that part of column D which belongs to the list identified in C3. The function returns 0 if no match was found, either of the list or the ID.
You didn't specify what you want to do with the found row. The procedure below will return data from that row. You might use the capability to address the cells to write to them instead.
Private Sub RetrieveData()
Dim R As Long
R = MatchRow
MsgBox "ID = " & Cells(R, NwsID).Value & vbCr & _
"Number = " & Cells(R, NwsNumber).Value
End Sub
Being intended for testing only the above proc doesn't specify the worksheet and, therefore, returns data from the ActiveSheet, presumed to be Sheet2.
VBA Solution
I think the non-VBA solution is ideal here, but I will leave this here separately just in case. This should work for your situation assuming no values in your tables are blank.
Sub Test()
Dim ws As Worksheet: Set Worksheet = ThisWorkbook.Sheets("Sheet2")
Dim iList As Range, iName As Range
Dim aLR As Long, cLR As Long
aLR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set iList = ws.Range("A1:A" & aLR).Find(ws.Range("C3"), LookIn:=xlWhole)
If Not iList Is Nothing Then
cLR = iList.Offset(0, 2).End(xlDown).Row
Set iName = ws.Range(ws.Cells(iList.Row, 3), ws.Cells(cLR, 3)).Find(ws.Range("C4"), LookIn:=xlWhole)
If Not iName Is Nothing Then
ws.Range("E3:G3").Value = iName.Offset(0, 1).Resize(1, 3).Value
End If
End If
End Sub
Non VBA Solution
Convert your two list ranges to tables
Change the name of your tables by (Formulas Tab > Name Manager > Select Table/Change Name). Specifically, you will want to change the names to your desired list name. (Table 1 Name = List1 & Table 2 Name = List2)
Next, drop these formulas inside E3, F3, & G3
E3 = VLOOKUP(D3, Indirect(C3), 2, 0)
F3 = VLOOKUP(D3, Indirect(C3), 3, 0)
G3 = VLOOKUP(D3, Indirect(C3), 4, 0)
This wil update dynamically as your table sizes expand. you can also add as many tables as you'd like and this will continue to work.
In use, it looks something like below
My last suggestion would be to nest each formula above inside an IFERROR()
I am new to VBA Excel programming. Consider an Excel sheet with nxn values. My task is to search for text called "TOOTHBRUSH BATT" from A column. A column consists of multiple "TOOTHBRUSH " value.
Once the value is found suppose in cell A11 then I need to change text in D11 ie corresponding D column to "BATTERY". D11 will already have some text, I need to replace that text with "BATTERY"
My code is
Sub replacement()
Dim S As String
Dim H As String
S = "TOOTHBRUSH BATT"
For i = 1 To Range("A1").End(xlDown).Row
If Range("A" & i) = S Then
Range("D" & i) = "BATTERY"
End If
Next i
End Sub
nRow = Worksheets(1).Range("A:A").Find(What:="*TOOTHBRUSH BATT*", after:=Range("A1"), LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Row
Worksheets(1).Cells(nRow,"D") = "BATTERY"
By using auto filter (below code not tested)
Worksheets(1).autofiltermode = false
Worksheets(1).Range("A:B").autofilter
Worksheets(1).AutoFilter.Range.AutoFilter Field:=1, Criteria1:="*TOOTHBRUSH BATT*"
dim nRng as range
If Worksheets(1).AutoFilter.Range.Offset(1,0).Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
set nRng = Worksheets(1).AutoFilter.Range.Offset(1,0).Columns(2).Resize(Worksheets(1).AutoFilter.Range.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
nRng.value = "BATTERY"
End If
This is Similar to Eric's Answer.
' Declare range to set to the first cell we find
Dim find as Range
set find = Range("A:A").Cells.Find(What:="TOOTHBRUSH BATT")
' This is the cell Address (in case it keeps looping back to beginning)
Dim addy as string
if not find is nothing then addy = find.address
' If we've found a cell then Keep Do something with it
Do while not find is nothing
find.Value = "BATTERY"
' Find the next Cell
set find = Range("A:A").Cells.Find(What:="TOOTHBRUSH BATT", After:= find)
' If the next found cell is the first one then exit sub/function
if find.address = addy then exit sub
Loop