As the title states, I need to find all cells in a worksheet with a specific string in them and replace the cell 2 columns to the right with a specific value
Edit: this is what I have so far but no idea where to go from here
Sub t()
Dim searchCell As Range
Dim replaceCell As Range
With Sheets("Chainwire")
Set searchCell = .Cells.Find(what:="UFFT50")
Set replaceCell = searchCell.Offset(0, 2)
End With
End Sub
Any help is much appreciated
Try this:
Sub ReplaceItems()
Dim col, c, dest As Range
Set col = FindAll(Sheets("Chainwire").UsedRange, "UFFT50") 'get all matches
'loop matches and replace value 2 cells over
For Each c In col
c.Offset(0, 2).Value = "a specific value"
Next
End Sub
'search a Range for `val` and return all matches as a Collection
' of cells
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
'adjust Find() arguments to suit your need...
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If Not f Is Nothing Then addr = f.Address() 'remember first cell found
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do 'exit if we looped back to the first hit
Loop
Set FindAll = rv
End Function
Related
This is the code i have, but at the line containing the .FindNext expression runtime error 438 shows up. Where is the problem?
Dim bottomCell As Range
Dim offsetCell As Range
With Sheets("C7BB2HD3IINA_NRM_X302")
Set bottomCell = .Cells.Find(what:="KENNFELD")
Set offsetCell = bottomCell.Offset(0, 1)
Set offsetCell = .FindNext(offsetCells)
End With
Using Find/FindNext is complex enough that you should split it out into a separate function which just returns the matches. That way you can focus on the main logic instead of getting tangled up in the Find process.
Try this:
Sub tester()
Dim col As Collection, c
Set col = FindAll(ThisWorkbook.Worksheets("C7BB2HD3IINA_NRM_X302").Cells, _
"KENNFELD", xlWhole) 'or xlPart
For Each c In col 'loop over matches
MsgBox c.Offset(0, 1).Value
Next c
End Sub
'Find all matches for `val` in `rng` and return as a Collection of cells
Public Function FindAll(rng As Range, val As String, matchType As XlLookAt) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
LookIn:=xlValues, LookAt:=matchType, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
I need help with the script below. I need to highlight all cells in range(r) which contain values from another range(dictionary), but currently it only highlights first occurrences of each cell in the dictionary range.
Sub SearchAndFormat_Click()
Dim Dictionary As Variant
Dictionary = Range("L5:L9")
Dim r As Range, cell As Variant
Set r = Application.InputBox("Select range", "Selection Window", Type:=8)
r.ClearFormats
r.NumberFormat = "General"
For Each subj In Dictionary
For Each cell In r
Set target_cell = r.Find(subj, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not target_cell Is Nothing Then
target_cell.Interior.ColorIndex = 4
End If
Next
Next
End Sub
I used to have a version of code without nested loop, but it would only highlight the first occurrence of the first value in the dictionary range:
For Each cell In r
Set target_cell = r.Find(Dictionary, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not target_cell Is Nothing Then
target_cell.Interior.ColorIndex = 4
End If
Next
Any help is greatly appreciated!
If you use Find in order find all values equal to the target, then it should be sort of a Do ... Loop with active use of a parameter After:=... For example:
Set x = MyRange.Find(target)
If Not x Is Nothing Then
Start = x.Address
Do
Debug.Print x.Address, x.Value
Set x = MyRange.FindNext(After:=x)
Loop While x.Address <> Start
End If
But there's no need to use Find when you loop through each value in a dictionary and in a range of interest:
Sub test_colorizing()
Dim d As Range
Dim r As Range
Dim x, y
Set d = Range(...) ' Dictionary
Set r = Range(...) ' Range of interest
For Each x In r
For Each y In d
If x = y Then
x.Interior.ColorIndex = 4
Exit For ' go to the next word in r
End If
Next
Next
End Sub
How it can look with Find:
Sub test_colorizing_with_find()
Dim dict As Range ' Dictionary
Dim rng As Range ' Range of interest
Dim cell, word, start
Set dict = Range(...)
Set rng = Range(...)
For Each word In dict
Set cell = rng.Find(word)
If Not cell Is Nothing Then
start = cell.Address
Do
cell.Interior.ColorIndex = 4
Set cell = rng.FindNext(cell)
Loop While cell.Address <> start
End If
Next
End Sub
I have 2 different sheet file on excel. I will try to find the equivalent of the date value I entered on the first page on the second page. I want to paste a block from the first cell, two cells to the right of the address of the value I found.
So I wrote a code block as below
Dim aranan As Date
Dim firstAddress As String
Dim adres As Range
Dim c As Range
Private Sub CommandButton2_Click()
aranan = Range("B1").Value
Range("B2:G6").Select
Selection.Copy
With Worksheets(3).Range("A1:A500")
Set adres = Range("A1:A100").Find(aranan, LookAt:=xlWhole, MatchCase:=True)
If Not adres Is Nothing Then
firstAddress = adres.Address
Do
ActiveSheet.Paste Destination:=Worksheets(2).Range("C1:H5")
Loop While Not adres Is Nothing
End If
End With
End Sub
But when debugging, I see that the value of my variable named "adres" is empty.
The variable with the name "aranan" holds the date name.
What is my mistakes?
The "find all matches" logic is complex enough that it should be placed in a separate method - that makes your core logic simpler to manage.
For example:
Private Sub CommandButton2_Click()
Dim dt As Date, col As Collection, c As Range
dt = Me.Range("B1").Value 'Me = the worksheet for this code module
Set col = FindAll(Worksheets(3).Range("A1:A500"), dt)
If col.Count > 0 Then
For Each c In col
Me.Range("B2:G6").Copy c.Offset(0, 2) 'two columns over
Next c
Else
MsgBox "No matches found"
End If
End Sub
'find all matches for `val` in a range, and return as a collection
Public Function FindAll(rng As Range, val) As Collection
Dim rv As New Collection, f As Range, addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address() 'first cell found
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do 'exit if we've wrapped back to the start
Loop
Set FindAll = rv
End Function
search entire Excel workbook for text string and highlight cell appears to be exactly what I need but I can't get it to work on my Excel workbook. I have hundreds of rows across 10 worksheets. All searched-for Strings (Packet 01, Packet 02, Packet 03, etc) would be in B:8 to row-end on worksheet(1) and B:7 to row-end on the other 9 worksheets (Worksheets are named and the InputBox result for the string would need to be case-sensitive). 45547221 indicates interior color change, but there would be too much color with all strings having cells in different colors, thus changing the string color would be better using font.color.index. Trying the 45547221 code as-is finds it skipping the Do/Loop While code when in step mode.
I would modify the code in 45547221 by adding at a minimum:
Dim myColor As Integer
myColor = InputBox("Enter Color Number (1-56)")
(Configured so I can enter up to 5 FindStrings and 5 ColorIndex numbers as Dim with InputBox(es))
In the Do/Loop While I would change .ColorIndex = myColor
I would like to get this code working as it seems to fit my needs - modified to find string instances across workbook and re-color string instead of cell interior colors and (2) get it to recognize the Do/Loop While code which it isn't now but would apply the ColorIndex number to each string.
Public Sub find_highlight()
'Put Option Explicit at the top of the module and
'Declare your variables.
Dim FindString As String
Dim wrkSht As Worksheet
Dim FoundCell As Range
Dim FirstAddress As String
Dim MyColor As Integer 'Added this
FindString = InputBox("Enter Search Word or Phrase")
MyColor = InputBox("Enter Color Number")
'Use For...Each to cycle through the Worksheets collection.
For Each wrkSht In ThisWorkbook.Worksheets
'Find the first instance on the sheet.
Set FoundCell = wrkSht.Cells.Find( _
What:=FindString, _
After:=wrkSht.Range("B1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'Check it found something.
If Not FoundCell Is Nothing Then
'Save the first address as FIND loops around to the start
'when it can't find any more.
FirstAddress = FoundCell.Address
Do
With FoundCell.Font 'Changed this from Interior to Font
.ColorIndex = MyColor
'.Pattern = xlSolid
'.PatternColorIndex = xlAutomatic 'Deactivated this
End With
'Look for the next instance on the same sheet.
Set FoundCell = wrkSht.Cells.FindNext(FoundCell)
Loop While FoundCell.Address <> FirstAddress
End If
Next wrkSht
End Sub
EDIT: This worked for me on your sample data, using a partial match so you can enter (eg) "Packet 03" and still match.
I like to split out the "find all" function into a separate function: it makes the rest of the logic easier to follow.
Public Sub FindAndHighlight()
Dim FindString As String
Dim wrkSht As Worksheet
Dim FoundCells As Range, FoundCell As Range
Dim MyColor As Integer 'Added this
Dim rngSearch As Range, i As Long, rw As Long
FindString = InputBox("Enter Search Word or Phrase")
MyColor = InputBox("Enter Color Number")
'Cycle through the Worksheets
For i = 1 To ThisWorkbook.Worksheets.Count
Set wrkSht = ThisWorkbook.Worksheets(i)
rw = IIf(i = 1, 8, 7) '<<< Row to search on
' row 8 for sheet 1, then 7
'set the range to search
Set rngSearch = wrkSht.Range(wrkSht.Cells(rw, "B"), _
wrkSht.Cells(Rows.Count, "B").End(xlUp))
Set FoundCells = FindAll(rngSearch, FindString) '<< find all matches
If Not FoundCells Is Nothing Then
'got at least one match, cycle though and color
For Each FoundCell In FoundCells.Cells
FoundCell.Font.ColorIndex = CInt(MyColor)
Next FoundCell
End If
Next i
End Sub
'return a range containing all matching cells from rng
Public Function FindAll(rng As Range, val As String) As Range
Dim rv As Range, f As Range
Dim addr As String
'partial match...
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True) 'case-sensitive
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
If rv Is Nothing Then
Set rv = f
Else
Set rv = Application.Union(rv, f)
End If
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
I have two spreadsheets, vda.xlsx and main.xlsm. At the moment I'm comparing the values in:
main.xlsm column J
with
vda.xlsx column A
To see if there is a match. If a match is found then the value in column gets highlighted in red.
However the format of the data in vda.xlsx column A has changed .
It used to look like this
1234
Now it looks like this
Test\1234 or Best\1234 or Jest\1234 - it could be anything...
Sp I need to split Test\1234 by the "\" and extract 1234 for comparison.
Any idea how I can accomplish this. This is my code so far:
Sub VDA_Update()
Dim wshT As Worksheet
Dim wbk As Workbook
Dim wshS As Worksheet
Dim r As Long
Dim m As Long
Dim cel As Range
Application.ScreenUpdating = False
Set wshT = ThisWorkbook.Worksheets("Master")
On Error Resume Next
' Check whether vda.xlsx is already open
Set wbk = Workbooks("vda.xlsx")
On Error GoTo 0
If wbk Is Nothing Then
' If not, open it
Set wbk = Workbooks.Open("C:\Working\vda_test.xlsx")
End If
' Set worksheet on vda.xlsx
Set wshS = wbk.Worksheets("imac01")
m = wshT.Cells(wshT.Rows.Count, 1).End(xlUp).Row
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
Application.ScreenUpdating = True
End Sub
Use Split(CellValue, "\") to get an array and then retrieve the last item in the array.
Change:
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
To something like:
' Loop though cells in column A on vda.xlsx
For r = 1 To m
' Can we find the value in column J of main.xlsm?
cellSplit = Split(wshS.Cells(r, 1).Value, "\")
Set cel = wshT.Columns(10).Find(cellSplit(UBound(cellSplit)), _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
cel.Cells(1, 1).Font.ColorIndex = 3
End If
Next r