Search two words at once - excel

I can search two words for example: LED LIGHT.
I want to search at once "LED LIGHT" or "LIGHT LED" no matter where "LED" or "LIGHT" is within the text.
Replacing the "space" between the words with wildcard "*" does help searching "LED LIGHT" regardless of the words position in text, but would not search in reverse "LIGHT LED".
Dim ws As Worksheet
Dim firstWord As String
Dim secondWord As String
Dim thirdWord As String
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim LastRow3 As Long
On Error GoTo Whoa
Set ws = Sheet1
firstWord = InputBox("Enter word for bullet_points", "Keyword BOX")
secondWord = InputBox("Enter word for item_name", "Keyword BOX")
thirdWord = InputBox("Enter word for product_description", "Keyword BOX")
LastRow1 = Cells(Rows.Count, 8).End(xlUp).Row + 1
If firstWord = "" Then
ActiveSheet.Cells(LastRow1, 8).Value = "No INPUT"
Else
ActiveSheet.Cells(LastRow1, 8).Value = firstWord
End If
LastRow2 = Cells(Rows.Count, 9).End(xlUp).Row + 1
If secondWord = "" Then
ActiveSheet.Cells(LastRow2, 9).Value = "No INPUT"
Else
ActiveSheet.Cells(LastRow2, 9).Value = secondWord
End If
LastRow3 = Cells(Rows.Count, 10).End(xlUp).Row + 1
If thirdWord = "" Then
ActiveSheet.Cells(LastRow3, 10).Value = "No INPUT"
Else
ActiveSheet.Cells(LastRow3, 10).Value = thirdWord
End If
With ws
If firstWord <> "" Then ReplaceText ws.Range("B17:B4001"), firstWord
If secondWord <> "" Then ReplaceText ws.Range("C17:C4001"), secondWord
If thirdWord <> "" Then ReplaceText ws.Range("D17:D4001"), thirdWord
End With
Exit Sub
Whoa:
msgbox Err.Description
End Sub
Private Sub ReplaceText(rng As Range, txt As String)
Dim aCell As Range
Dim bCell As Range
Dim rngFound As Range
Set aCell = rng.Find(What:=txt, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
Set rngFound = aCell
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Set rngFound = Union(rngFound, aCell)
Else
Exit Do
End If
Loop
End If
If Not rngFound Is Nothing Then
rngFound.Value = "XXXXXXXXXXXXX"
End If

I'm afraid your intention is only partially clear. Therefore my solution below consists of two unconnected parts. In the first part the user enters 3 search words and a record is made in Sheet1 of what was entered. In the second part, the function inaptly named ReplaceText, a cell is looked for that contains all the words the user entered. Note that "" will be found in every cell. Therefore, if the user entered blanks they will have no effect on the search. What will have an effect is that "LED Lighting" will be found if "LED Light" was looked for. Please bear that in mind.
Sub Test_Replace()
' 010
Dim searchWord(1 To 3) As String
Dim Clm As Long
Dim C As Long
Dim i As Integer
searchWord(1) = InputBox("Enter word for bullet_points", "Keyword BOX")
searchWord(2) = InputBox("Enter word for item_name", "Keyword BOX")
searchWord(3) = InputBox("Enter word for product_description", "Keyword BOX")
Clm = 2 ' first column to replace
With Sheet1
For C = 8 To 10
i = i + 1
If Len(searchWord(i)) = 0 Then searchWord(i) = "No INPUT"
.Cells(.Rows.Count, C).End(xlUp).Offset(1).Value = searchWord(i)
Clm = Clm + 1
Next C
' If firstWord <> "" Then ReplaceText Ws.Range("B17:B4001"), firstWord
' If secondWord <> "" Then ReplaceText Ws.Range("C17:C4001"), secondWord
' If thirdWord <> "" Then ReplaceText Ws.Range("D17:D4001"), thirdWord
End With
End Sub
Private Function ReplaceText(Rng As Range, _
searchWord() As String) As boolean
Dim Fnd As Range
Dim FndVal As String
Dim i As Integer
Set Fnd = Rng.Find(What:=searchWord(3), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not Fnd Is Nothing Then
Do Until Fnd Is Nothing
FndVal = Fnd.Value
' compare case-insensitive
For i = 2 To 1 Step -1
If InStr(1, FndVal, searchWord(i), vbTextCompare) = 0 Then Exit For
Next i
If i = 0 Then
Set Rng = Fnd
ReplaceText = True
Exit Do
End If
Set Fnd = Rng.FindNext(Fnd)
Loop
End If
End Function
In the first procedure the difference between my code and yours is in the replacement of the ActiveSheet with Sheet1. Observe that the variable Clm is set up to pass the range "B17:B4001", C and D, perhaps in the loop, but I didn't manage to logically connect this.
The function looks for the 3rd word first. If that is a blank the search can take a long time because every cell in the searched range qualifies. If searchWord(3) is found the code will look for (2) and (1) and return the cell as the result if all three are found. Else the function will look for the next pre-qualified cell. You can refine the qualifying process to make sure that Delight will not be mistaken for Light.
The function returns True or False, depending upon whether a match was found. If the answer is True the Rng variable passed to it as argument will contain the address of where the match was found. Here is the function call I used in my tests.
Private Sub TestFind()
Dim Rng As Range
Dim Sw() As String
Sw = Split(" One Two Three")
Set Rng = Range("A2:A25")
Debug.Print ReplaceText(Rng, Sw), Rng.Address
End Sub
If the function returned False Rng.Address will be "A2:A25"

Related

Search for all values between 2 values in a column and loop till last one found

Lets start with I am self taught in Excel VBA and have a question that might seem stupid or basic:
I have the following information on a sheet:
[ConfBlastPlan]
DRB1065
PU1962;427;05_37_OB;A;2;2;1
PU1963;364;05_37_OB;B;2;2;1
PU1959;373;05_37_OB;C;2;2;1
-
[FiringProcedure]11:55:21;MULTI
What I want to do is combine all strings between with "PU" and the first ";" that is found between the
"[ConfBlastPlan]" and [FiringProcedure] into one cell.
I have read up about the loop function but seems I have confused myself terribly.
How do I loop this and combine the strings found?
I have started the function using the following code:
Sub DRBEquipNumberPU() 'GET THE PU#s
Dim WSFrom As Worksheet
Dim WSTo As Worksheet
Dim RngFrom As Range
Dim RngTo As Range
Dim BlastNumber As String
Dim BlastNumberStep As Long
Dim SearchString As String
Dim SearchStringStart As String
Dim SearchStringEnd As String
Dim LineStep As Long
Dim Blastedrng As Range
Dim BlastedFoundrng As Range
Dim closePos As Integer
BlastNumberStep = 1
LineStep = 1
Set Blastedrng = ThisWorkbook.Worksheets("Blast Summary Sheet").Range("A2", Range("A2").End(xlDown))
For Each BlastedFoundrng In Blastedrng.Cells
On Error Resume Next
SearchString = "[ConfBlastPlan]"
SearchStringStart = "PU"
SearchStringEnd = "[FiringProcedure]"
BlastNumber = CStr("Blasted " & BlastNumberStep)
Set WSFrom = Worksheets(CStr(BlastNumber))
Set RngFrom = WSFrom.Cells.Find(What:=SearchString, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set RngFrom1 = WSFrom.Cells.Find(What:=SearchStringStart, After:=RngFrom, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set WSTo = ThisWorkbook.Worksheets("Blast Summary Sheet")
Set RngTo = WSTo.Cells.Find(What:=(CStr(BlastNumber)), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
closePos = InStr(1, RngFrom.Cells.Value, ";")
If RngTo.Cells.Offset(0, 4).Value = "INCOMPLT" Then
RngTo.Cells.Offset(0, 7).Value = "INCOMPLT"
ElseIf RngFrom.Cells.Value Is Nothing Then
RngTo.Cells.Offset(0, 7).Value = "NO PU #s"
ElseIf RngFrom.Cells.Value Like SearchStringStart Then
RngTo.Cells.Offset(0, 7).Value = Mid(RngFrom.Cells.Value, 0, closePos)
ElseIf RngFrom.Cells.Value = SearchStringEnd Then
End If
BlastNumberStep = BlastNumberStep + 1
Next BlastedFoundrng
End Sub
All it returns at the moment is INCOMPL or NO PU #s
There can be a maximum of 48 instances of PU
Please help
Blasted 23:
Blasted 26:
Blasted 27:
Option Explicit
' Major changes: make it two steps-- 1)Get all Sheet names, 2)Process all Lines on one sheet
Sub StepThruBlastedSheetNames() 'GET THE PU#s
Dim WSSummary As Worksheet, rowSummary As Long
Set WSSummary = ThisWorkbook.Worksheets("Blast Summary Sheet")
rowSummary = 1
Dim WSFrom As Worksheet
For Each WSFrom In ThisWorkbook.Worksheets
If InStr(WSFrom.Name, "Blasted ") > 0 Then
StepThruBlastedLines WSSummary, rowSummary, WSFrom
End If
Next
End Sub
Sub StepThruBlastedLines(WSSummary As Worksheet, rowSummary As Long, WSFrom As Worksheet)
' these never change, ergo do not put inside loop
Const SearchStringStart As String = "[ConfBlastPlan]"
Const SearchStringFindPU As String = "PU"
Const SearchStringEnd As String = "[FiringProcedure]"
Dim rowFrom As Long
Dim rowMax As Long
rowMax = WSFrom.Cells(WSFrom.Rows.Count, "A").End(xlUp).Row
Dim IsBetween As String, PUlist As String, posSemi As Long, DRBname As String
IsBetween = "N"
PUlist = ""
DRBname = ""
For rowFrom = 1 To rowMax
If IsBetween = "Y" Then
If InStr(WSFrom.Cells(rowFrom, "A"), "DRB") > 0 Then
DRBname = WSFrom.Cells(rowFrom, "A")
End If
If InStr(WSFrom.Cells(rowFrom, "A"), SearchStringFindPU) > 0 Then
posSemi = InStr(WSFrom.Cells(rowFrom, "A"), ";")
PUlist = PUlist & Mid(WSFrom.Cells(rowFrom, "A"), 1, posSemi)
End If
If InStr(WSFrom.Cells(rowFrom, "A"), SearchStringEnd) > 0 Then
IsBetween = "N"
rowSummary = rowSummary + 1
WSSummary.Cells(rowSummary, "A") = WSFrom.Name
WSSummary.Cells(rowSummary, "B") = DRBname
If PUlist <> "" Then
WSSummary.Cells(rowSummary, "C") = PUlist
PUlist = ""
Else
'<< add put empty notice
WSSummary.Cells(rowSummary, "C") = "INCOMPL"
End If
DRBname = "" '<<added
End If
ElseIf WSFrom.Cells(rowFrom, "A") = SearchStringStart Then
IsBetween = "Y"
End If
Next rowFrom
End Sub
Here's code that extracts the PU-values from a worksheet like the one you posted. I couldn't figure out why you called this worksheet WsTo and perhaps that's the reason why I also couldn't guess at your intention for what to do with the result. Your question is mute on the point. So I left the project at that point. I'm sure you will be able to pick it up from the two ways I'm displaying the Output array.
Sub DRBEquipNumberPU()
' 134
' Get the PU#s
Const Blast As String = "[ConfBlastPlan]"
Const BlastEnd As String = "-"
Const Marker As String = "PU"
Dim WsTo As Worksheet
Dim BlastFound As Range
Dim CellVal As String ' loop variable: Cell.Value
Dim R As Long ' loop counter: rows
Dim Output As Variant ' array of found values
Dim i As Long ' index to Output
Set WsTo = ThisWorkbook.Worksheets("Blast Summary Sheet")
With WsTo.Columns(1)
Set BlastFound = .Find(What:=Blast, _
LookIn:=xlValues, _
Lookat:=xlWhole, _
MatchCase:=False)
If BlastFound Is Nothing Then
MsgBox """" & Blast & """ wasn't found.", _
vbInformation, "No data to process"
Else
ReDim Output(1 To 100) ' choose UBound larger than you ever need
R = BlastFound.Row
Do
R = R + 1
CellVal = .Cells(R).Value
If InStr(1, Trim(CellVal), Marker, vbTextCompare) = 1 Then
i = i + 1
Output(i) = CellVal
End If
Loop While Len(CellVal) And CellVal <> BlastEnd
If i Then
ReDim Preserve Output(1 To i)
MsgBox "Found values = " & vbCr & _
Join(Output, Chr(13))
For i = LBound(Output) To UBound(Output)
Debug.Print Output(i)
Next i
End If
End If
End With
End Sub
It just occurs to me that the end marker you suggested ("FiringProcedure]") may be more reliable than my choice ("-"). If so, just change it at the top of the code where the constants are declared. If that marker is missed the code might continue to include the "PU" line below the [Blasting Plan] row.

Highlight all words in a long text that is in a Cell

I am trying to develop a Find button, to mark in red "ALL" of the word that are contained in a cell.
For example If I have in my cell this text.
"Pepper had peppermint in his pocket"
it should change to this.
"Pepper had peppermint in his pocket"
This code highlights the first word that it finds.
Dim i As Long
Dim oldrngrow As Long
Dim myValue As String
Dim arr() As Variant
arr = Array(TextBox1.Value)
TextBox2.Text = UBound(arr)
For i = 1 To UBound(arr) + 1
myValue = arr(i - 1)
If myValue = vbNullString Then
MsgBox ("Please Enter a Word in Textbox")
End
End If
Set rng = Cells.Find(What:=myValue, After:=Cells(1, i), LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, MatchByte:=True, SearchFormat:=False)
If rng Is Nothing Then
GoTo skip
End If
oldrngrow = rng.Row
Do While rng.Column = i
If ComboBox1.Text = "Red" Then
rng.Characters(InStr(rng, myValue), Len(myValue)).Font.ColorIndex = 3
Set rng = Cells.FindNext(After:=rng)
If oldrngrow = rng.Row Then
Exit Do
End If
Loop
skip:
Next i
Interesting question. After some research, I’ve put together the following code to demonstrate how to highlight every instance of a word in a string within a cell. For the sake of the demonstration, it uses an Input Box to get the desired string-to-highlight (you can change the method), and assumes the range to search is simply A1 – again you can change this to whatever you want.
Make sure you include Option Compare Text at the top of the Sub – otherwise the search will be case sensitive. Let me know how you go.
Option Compare Text
Sub StringColor()
Dim myRange As Range, myCell As Range, myString As String, myCount As Integer
Set myRange = Range("A1")
myString = InputBox("Type the word you want to color in A1")
For Each myCell In myRange
For myCount = 1 To Len(myCell) - Len(myString) + 1
If Mid(myCell, myCount, Len(myString)) = myString Then
myCell.Characters(myCount, Len(myString)).Font.Color = vbRed
End If
Next myCount
Next myCell
End Sub

How to Find, cut, paste and erase with VBA code

I am new on VBA and i dont know almost nothing.
I've been trying a code to find a value entered in a inputbox "CXRG", find on sheet "ESTOQUEV" cut all the line and paste on sheet "SAIDA" (down from another values) and erase the blank line from "ESTOQUEV"
Someone could help me?
Private Sub CommandButton1_Enter()
linha = Worksheets("SAIDA").Range("A100000").End(xlUp).Row + 1
Worksheets("SAIDA").Cells(linha, 1) = CXOS.Value
Worksheets("SAIDA").Cells(linha, 2) = CXRG.Value
CXOS.Text = ""
CXRG.Text = ""
SendKeys "{TAB}", True ' Envia TAB para pular par o inicio.
Call refresh.Macro8
End Sub
you have to try this code (run just findAndPast())
Sub findAndPast()
Dim shttoFind As Worksheet
Dim shttoPast As Worksheet
Dim LastRowOffind As Long
Dim inBox As String
Dim cell As Range
Set shttoFind = Worksheets("ESTOQUEV")
Set shttoPast = Worksheets("SAIDA")
Call Find_Last
LastRowOffind = shttoPast.Cells(shttoPast.Rows.Count, "A").End(xlUp).Row + 1
ActiveCell.EntireRow.Copy
shttoPast.Activate
shttoPast.Cells(LastRowOffind, 1).PasteSpecial
shttoFind.Activate
ActiveCell.EntireRow.Delete
End Sub
Sub Find_Last()
Dim FindString As String
Dim Rng As Range
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With Sheets("ESTOQUEV").Range("A:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub

Loop through cells and display a message if a value is not found

I have a macro that loops through cells of one sheet, looks for that value in another sheet, and then highlights the row if they match. I'd like to add a message box that would pop up if a matching value is not found. I know this is a simple problem, but I'm having trouble figuring out in which loop to put my booleans.
Sub MarkXfer_noX()
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim j As Integer
Dim ProdCI As String
Dim found As Boolean
Dim intRowCount As Integer
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
For j = 2 To rng2.Rows.count 'from row 2 to the end
If rng2.Cells(j, 2) = ProdCI Then 'if the ProdCI in column B matches the one we picked,
Call FillCell(j) 'call a sub in a different module and give it our current row
found = True
Else
found = False
End If
Next
Next
If found = False Then
MsgBox (ProdCI & " not found") 'Display a message if one of the items wasn't found on the main page. Currently has an error where the last one in the list always pops up.
Else
End If
End Sub
Right now it always shows a msgbox with the last value in the range no matter what.
Thanks all, here is the updated working code using the Find function
Sub MarkXfer_Find()
'Re-tooled to use the .Find function instead of looping through each
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim ProdCI As String
Dim intRowCount As Integer
Dim intRowCount2 As Integer
Dim aCell As Range
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
intRowCount2 = Worksheets("All_ProCI").UsedRange.Rows.count
'use the Find function to put a value in aCell
Set aCell = rng2.Range("B1:B" & intRowCount2).Find(What:=ProdCI, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'MsgBox ProdCI & " found"
Call FillCell(aCell.row)
Else 'If aCell is blank display msgbox
MsgBox "ProdCI """ & ProdCI & """ not found"
End If
Next
End Sub

Search for a string in a Worksheet using VBA

I am trying to search for a particular string "ERROR" in all the worksheets in the workbook and make it bold and color the found cell red.
I am able to parse through each worksheet. I am not able to use the Find function of VBA.
Here's an example of using Find and formatting the found cells
Sub FindERROR()
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = "ERROR"
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
if you are searching in excel vba you can use following simple code with InStr command.
Private Sub CommandButton1_Click()
Dim RowNum As Long
RowNum = 1
Do Until Sheets("Data").Cells(RowNum, 1).Value = ""
If InStr(1, Sheets("Data").Cells(RowNum, 2).Value, TextBox1.Value, vbTextCompare) > 0 Then
On erro GoTo next1
ListBox1.AddItem Sheets("Data").Cells(RowNum, 1).Value
ListBox1.List(ListBox1.ListCount - 1, 1) = Sheets("Data").Cells(RowNum, 2).Value
End If
next1:
RowNum = RowNum + 1
Loop
End Sub
you can download example file from here
How about this:
If Not WorkBook.Sheets("Sheet1").Range("A1:Z150").Find("Cookie") Is Nothing
MsgBox "Found a Cookie"
End If

Resources