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
Related
I am trying to work on a VBA macro that would extract two numbers from a cell and then add them together. The spreadsheet I am working on has a field like this:
Cell D1: .60 #2021-71; 0.90 #2021-71
I need to take the .60 and .90 out, add them together, and place them back in the cell.
For reference, there are other cells in this column that are like this:
Cell D2: .70 #2021-71
I have code that is already looking through the column and removing everything from the # sign on:
Dim tmp As String
For Each cell In Range("D:M")
If InStr(cell.Value, "#") > 0 Then
tmp = cell.Value
cell.Value = Left(tmp, InStr(tmp, "#") - 1)
End If
Is what I am trying to do even possible?
I've taken the approach of providing a custom function which you can then refer to on sheet.
You can call the function whatever you want...!
Public Function SumFirstNumbers(ByVal rngCell As Range) As Variant
Dim arrValues, i As Long, strValue As String, dblValue As String
If InStr(1, rngCell.Text, "#") > 0 Then
arrValues = Split(rngCell.Text, ";")
For i = 0 To UBound(arrValues)
dblValue = 0
strValue = Split(Trim(arrValues(i)), " ")(0)
If IsNumeric(strValue) Then dblValue = CDbl(strValue)
SumFirstNumbers = CDbl(SumFirstNumbers) + dblValue
Next
Else
SumFirstNumbers = rngCell.Value
End If
End Function
Then just use it like any other function in a cell...
This way, you can fill down and across and not have to worry about where the source data actually resides.
To then put it back in the original cells, just Copy → Paste Special → Values.
If it produces an incorrect result (before copying back to the original cells), the function can be changed and the data is still protected.
Naturally, this could still be incorporated into a wider macro if need be. You just need to apply it to your original code.
Dim tmp As String
For Each cell In Range("D:M")
If InStr(cell.Value, "#") > 0 Then
tmp = cell.Value
cell.Value = SumFirstNumbers(cell)
End If
Next
... something like that anyway.
Non VBA Method
Using formulas only. I have indented the formula (you can do that in the formula bar) for a better understanding.
=IFERROR(
IF(
ISNUMBER(SEARCH(";",D1)),
VALUE(MID(D1,SEARCH(";",D1)+1,SEARCH("#",D1,SEARCH(";",D1)+1)-SEARCH(";",D1)-1)) + VALUE(LEFT(D1,SEARCH("#",D1)-1)),
VALUE(LEFT(D1,SEARCH("#",D1)-1))
),0
)
Logic:
Check if there is ; using SEARCH(). Use ISNUMBER() to handle the formula if it doesn't exist.
If there is ; then get the text between ; and # using MID(). Convert them to values using VALUE() and add them up.
If there is no ; then just use LEFT() to get the number before #.
VBA Method
In case you are looking for VBA method to replace the values in the same column then here is a faster method using WildCards. If you have lots of data then in the end where I am using For Each aCell In rng, put the data in an array and loop the array instead.
Logic:
Make Excel do most of the Dirty work!
Replace every thing that is between ";" and "#" with "" using inbuit .Replace with wildcard "#*;"
Replace every thing that is after "#" with "" using wildcard "#*"
Remove all spaces
Use Evaluate.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
Dim lRow As Long
Set ws = Sheet1
With ws
With .Columns(4)
.Replace What:="#*;", Replacement:="+", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:="#*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End With
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set rng = .Range("D1:D" & lRow)
For Each aCell In rng
aCell.Value = .Evaluate(aCell.Value)
Next aCell
End With
End Sub
In Action
Replace by Numbers
Option Explicit
Sub ReplaceByNumbers()
Const Cols As String = "D:M"
Const FindDelimiter As String = "#"
Const SplitDelimiter As String = ";"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim rg As Range: Set rg = Intersect(ws.UsedRange, ws.Columns(Cols))
If rg Is Nothing Then Exit Sub ' no data
Dim rCount As Long: rCount = rg.Rows.Count
Dim cCount As Long: cCount = rg.Columns.Count
Dim Data As Variant
If rCount + cCount = 2 Then ' one cell only
ReDim Data(1 To 1, 1 To 1): Data(1, 1).Value = rg.Value
Else ' multiple cells
Data = rg.Value
End If
Dim SubStrings() As String
Dim r As Long, c As Long, n As Long
Dim iPos As Long
Dim Total As Double
Dim cString As String
Dim NumberFound As Boolean
For r = 1 To rCount
For c = 1 To cCount
cString = CStr(Data(r, c))
iPos = InStr(cString, FindDelimiter)
If iPos > 0 Then
SubStrings = Split(cString, SplitDelimiter)
For n = 0 To UBound(SubStrings)
If n > 0 Then
iPos = InStr(SubStrings(n), FindDelimiter)
End If
cString = Trim(Left(SubStrings(n), iPos - 1))
If Left(cString, 1) = "." Then cString = "0" & cValue
If IsNumeric(cString) Then
If NumberFound Then
Total = Total + CDbl(cString)
Else
Total = CDbl(cString)
NumberFound = True
End If
End If
Next n
If NumberFound Then
Data(r, c) = Total
NumberFound = False
End If
End If
Next c
Next r
rg.Value = Data
MsgBox "Replaced by numbers.", vbInformation, "ReplaceByNumbers"
End Sub
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"
I have some VBA experience, I can read and understand the coding, but have problems finding the proper codes.
Now, I have a userform where by the user would key in his ID, excel would then open up the database and search and return the results of the cells beside the found ID. the results would be returned and overwrite label 1 and label 2. And when the user clicks on the "next" or "previous" button, the next or previous results would then overwrite both labels.
The code I have right now allows me to search for the locations of the found ID and output the location in a format such as ($A$2,$A$3,$A$4,$A$6). The problem is that I am not sure what is the right functions that can then break this into individual range that the "next" or "previous" button can then refer to.
Have added my code
Dim cell As Range
Dim bcell As Range
Dim foundat As String
Dim oRange As Range
Dim userid As String
Dim x As Long
Dim y As Long
Dim Prob As String
Dim ws As Worksheet
Set ws = Worksheets("OFI")
Set oRange = ws.Columns(1)
userid = txt_user.Text
Set cell = oRange.Find(what:=userid, after:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not cell Is Nothing Then
Set bcell = cell
foundat = cell.Address
Do
Set cell = oRange.FindNext(after:=cell)
If Not cell Is Nothing Then
If cell.Address = bcell.Address Then Exit Do
foundat = foundat & ", " & cell.Address
Else
Exit Do
End If
Loop
Else
msgbox userid & "not found"
Exit Sub
End If
capproblem_output.Caption = foundat
Exit Sub
You need to add two command buttons with name cmdNext & cmdPrev , label with name capproblem_output2 to run the below code. Copy the code to userform code section.
Public foundat As String
Private Sub cmdNext_Click()
capproblem_output.Caption = ActiveCell.Offset(1, 1)
capproblem_output2.Caption = ActiveCell.Offset(1, 1)
ActiveCell.Offset(1, 0).Select
End Sub
Private Sub cmdPrev_Click()
capproblem_output.Caption = ActiveCell.Offset(-1, 1)
capproblem_output2.Caption = ActiveCell.Offset(-1, 1)
ActiveCell.Offset(-1, 0).Select
End Sub
Private Sub CommandButton1_Click()
Main
End Sub
Sub Main()
Dim cell As Range
Dim bcell As Range
Dim oRange As Range
Dim userid As String
Dim x As Long
Dim y As Long
Dim Prob As String
Dim ws As Worksheet
Set ws = Worksheets("OFI")
Set oRange = ws.Columns(1)
userid = UserForm1.txt_user.Text
Set cell = oRange.Find(what:=userid, after:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not cell Is Nothing Then
Set bcell = cell
foundat = cell.Address
Do
Set cell = oRange.FindNext(after:=cell)
If Not cell Is Nothing Then
If cell.Address = bcell.Address Then Exit Do
foundat = foundat & ", " & cell.Address
Else
Exit Do
End If
Loop
Else
MsgBox userid & "not found"
Exit Sub
End If
capproblem_output.Caption = Range(foundat).Offset(0, 1)
capproblem_output2.Caption = Range(foundat).Offset(0, 1)
End Sub
I'm looking to write a function in Excel to add leading zeroes to the octets that make up an IP address: e.g in 172.19.1.17 I want to to change .19. to .019., the .1. to .001., and the .17 at the end to .017.
Te Cells.Teplace function does not seem to accept ? as a wildcard. Also, is there a way I can represent 'end of string' so I'll be able to add leading zeroes to the last octet, .17 in the example above.
Thanks Ian
Cells.Replace What:=".1?.", Replacement:=".01?.", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
This does find "10." "11." "12." etc. but replaces them all with ".01?."
As an alternative you may use this formula to add zeros to IP parts (it looks terrible, but treats separately all the parts and finally mix them up):
=REPT(0,4-FIND(".",A1))&LEFT(A1,FIND(".",A1)-1)&"."&
REPT(0,4-FIND("#",SUBSTITUTE(A1,".","#",2))+FIND(".",A1))&MID(A1,FIND(".",A1)+1,FIND("#",SUBSTITUTE(A1,".","#",2))-FIND(".",A1)-1)&"."&
REPT(0,4-FIND("#",SUBSTITUTE(A1,".","#",3))+FIND("#",SUBSTITUTE(A1,".","#",2)))&MID(A1,FIND("#",SUBSTITUTE(A1,".","#",2))+1,FIND("#",SUBSTITUTE(A1,".","#",3))-FIND("#",SUBSTITUTE(A1,".","#",2))-1)&"."&
REPT(0,3-LEN(A1)+FIND("#",SUBSTITUTE(A1,".","#",3)))&RIGHT(A1,LEN(A1)-FIND("#",SUBSTITUTE(A1,".","#",3)))
You may paste it as it is to B1 (assuming your IPs are in column A starting A1) regardless line breaks.
Sample file: https://www.dropbox.com/s/vun6urvukch9uvv/IPoctets.xlsx
You could do something like this:
Be sure to replace Application.UsedRange with the actual range containing the IP addresses
Sub PadIP()
Dim Arr As Variant
Dim ipAddr As String
Dim vCell As Variant
Dim n As Long
'Replace ActiveSheet.UsedRange with the range containing your data
'
'If data is contained in column A and you have a column header
'Example: Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, 1))
For Each vCell In ActiveSheet.UsedRange
Arr = Split(vCell.Value, ".")
For n = 0 To UBound(Arr)
If (n + 1) Mod 4 = 0 Then
ipAddr = ipAddr & Right(String(3, "0") & Arr(n), 3)
Else
ipAddr = ipAddr & Right(String(3, "0") & Arr(n), 3) & "."
End If
Next
vCell.Value = ipAddr
ipAddr = ""
Next
End Sub
Can I play too :)?
This is further to my comment above. This is an example on how to find .??. and make it .0??.
I am assuming that the data can be ANYWHERE in the worksheet.
Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
Dim SearchString As String
On Error GoTo Whoa
Set ws = Worksheets("Sheet1")
Set oRange = ws.Cells
SearchString = ".??."
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Value = CleanIt(aCell.Value)
Do While ExitLoop = False
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Value = CleanIt(aCell.Value)
Else
ExitLoop = True
End If
Loop
End If
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Function CleanIt(rng)
Dim MyAr() As String
Dim strTemp As String
MyAr = Split(rng, ".")
For i = LBound(MyAr) To UBound(MyAr)
If Len(MyAr(i)) = 2 Then
MyAr(i) = "0" & MyAr(i)
End If
strTemp = strTemp & "." & MyAr(i)
Next i
CleanIt = Mid(strTemp, 2)
End Function
Screenshot
NOTE: This is just an example for demonstration purpose. The above code needs to be tweaked more so that it can handle other scenarios as well.
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