I have written a code, which includes the FindNext method. All the code works so far, only when it gets to the FindNext method it shows an error saying the FindNext Object cannot be assigned.
However, I don't see where the Range Object (in this case "cell") is changed in any way for the FindNext method to not be able to assign it. Has anybody got an idea?
Please ignore any chunky written code, I'm very new with VBA ;)
Sub Search()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim cell As Range, sngCell As Range
Dim Count As Long
Dim firstCell As String
Dim rg As Range, lastColumn As Long
Set cell = wks.Cells.Find(what:="Planned Supply at BP|SL (EA)", LookIn:=xlValues, lookat:=xlWhole)
firstCell = cell.Address
Do
With wks
lastColumn = .Cells(cell.Row, .Columns.Count).End(xlToLeft).Column
Set rg = Range(cell, .Cells(cell.Row, lastColumn))
End With
For Each sngCell In rg
If IsNumeric(sngCell.Value) = True Then
If sngCell.Value > 0 Then
If sngCell.Offset(-2, 0).Value > sngCell.Value Then
Count = Count + 1
End If
If Count = 0 Then
Rows(sngCell.Row - 2).Delete
Rows(sngCell.Row - 1).Delete
Rows(sngCell.Row).Delete
End If
End If
End If
Next
Set cell = wks.Cells.FindNext(cell)
Loop While cell.Address <> firstCell
End Sub
Find() in a loop is complex enough that it's worth splitting it out into a separate function. Here's a slightly different approach which reduces the complexity in your main Sub and allows you to focus on the business rules instead of the nuances of using Find()
Sub Search()
Dim wks As Worksheet
Dim cell As Range, sngCell As Range
Dim firstCell As String
Dim rg As Range, lastColumn As Long, matches As Collection
Set wks = ActiveSheet
Set matches = FindAll(wks.Cells, "Planned Supply at BP|SL (EA)")
For Each cell In matches
Debug.Print "Found:", cell.Address
Set rg = wks.Range(cell, wks.Cells(cell.Row, Columns.Count).End(xlToLeft))
For Each sngCell In rg.Cells
If IsNumeric(sngCell.Value) Then 'no need for `= True`
If sngCell.Value > 0 Then
If sngCell.Offset(-2, 0).Value <= sngCell.Value Then
sngCell.Offset(-2, 0).Resize(3).EntireRow.Delete
Exit For 'stop checking...
End If
End If
End If
Next
Next cell
End Sub
'Find all matches for `val` in `rng` and return as a collection
Public Function FindAll(rng As Range, val As String) 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()
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
Related
Sub Sample()
Dim fnd As String
Dim MyAr
Dim i As Long
Dim rng As Range, FoundCell As Range, LastCell As Range, myRange As Range
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
fnd = "university/checklist"
MyAr = Split(fnd, "/")
For i = LBound(MyAr) To UBound(MyAr)
Set FoundCell = myRange.Find(what:=MyAr(i), after:=LastCell)
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
End If
Set rng = FoundCell
Do Until FoundCell Is Nothing
Set FoundCell = myRange.FindNext(after:=FoundCell)
Set rng = Union(rng, FoundCell)
If FoundCell.Address = FirstFound Then Exit Do
Loop
If Not rng Is Nothing Then
rng.Characters.Font.ColorIndex = 3
End If
Next i
End Sub
Highlight Strings in Cells
Option Explicit
Sub HighlightStrings()
Const CriteriaList As String = "university,checklist"
Const CriteriaColor As Long = vbRed
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.UsedRange
Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
Dim c As Long
Dim cLen As Long
Dim cString As String
Dim fCell As Range
Dim fArr() As String
Dim f As Long
Dim fPos As Long
Dim fString As String
Dim fFirstAddress As String
For c = 0 To UBound(Criteria)
cString = Criteria(c)
cLen = Len(cString)
Set fCell = rg.Find(cString, , xlFormulas, xlPart)
If Not fCell Is Nothing Then
fFirstAddress = fCell.Address
Do
fString = fCell.Value
fPos = 1
fArr = Split(fString, cString, , vbTextCompare)
For f = 0 To UBound(fArr) - 1
fPos = fPos + Len(fArr(f))
fCell.Characters(fPos, cLen).Font.Color = CriteriaColor
fPos = fPos + cLen
Next f
Set fCell = rg.FindNext(fCell)
Loop Until fCell.Address = fFirstAddress
End If
Next c
MsgBox "Criteria strings highlighted.", vbInformation
End Sub
Please, try the next updated code. As I said in my above comment you cannot use a Union range for what you try doing, because you need to search for each cell and find the appropriate cell characters to be colored. You can iterate between such a range again but nothing will be gain:
Dim fnd As String, FirstFound As String, MyAr, i As Long, pos As Long
Dim FoundCell As Range, LastCell As Range, myRange As Range
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.cells(myRange.cells.count)
fnd = "university/checklist"
MyAr = Split(fnd, "/")
For i = LBound(MyAr) To UBound(MyAr)
Set FoundCell = myRange.Find(MyAr(i)), , , xlPart
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
pos = InStr(1, FoundCell.Value, MyAr(i), vbTextCompare)
FoundCell.Characters(pos, Len(MyAr(i))).Font.ColorIndex = 3
Do
Set FoundCell = myRange.FindNext(FoundCell)
pos = InStr(1, FoundCell.Value, MyAr(i))
FoundCell.Characters(pos, Len(MyAr(i))).Font.ColorIndex = 3
Loop While FoundCell.Address <> FirstFound
End If
Next i
End Sub
If the range to be processed is large, you should use some optimization lines as Application.ScreenUpdating = False, Application.EnableEvents = False and
Application.Calculation = xlManual at the beginning of the code and ending with Application.ScreenUpdating = False, Application.EnableEvents = False and
Application.Calculation = xlCalculationAutomatic
First of, try to tidy a bit your code example, it's quite messy hence I am not sure of what you are actually trying to achieve. Some accompanying comments would help also
Anyway, one thing is for sure :
rng.Characters.Font.ColorIndex = 3
will attribute a color to the whole text in the selected range. To specify only a subset of the text in the range, you need to use :
rng.Characters(Start:=x, Length:=y).Font.ColorIndex = 3
Where x being the starting character and Length being the length that you want to turn into the given font color.
You can find the start value and length using
start = InStr(1, rng, MyAr(i))
length = len(MyAr(i))
Which will lead to the following line
rng.Characters(Start:=start, Length:=length).Font.ColorIndex = 3
And as specified by FaneDuru, it should be done on a cell by cell basis. Either you do it instead of the Union, or you look on the cells within the rng.
for cell in rng.Cells
start = InStr(1, cell, MyAr(i))
...
next cell
Moreover, as described here, it will only color the first occurrence.
If the value you are looking for can appear several time, you either need an alternate way or set some iteration until there are no more matches by modifying the starting position in the InStr where 1 would become the last matched position + 1
This question already has answers here:
UDF using FindNext seems to abort without warning
(1 answer)
Why does my spreadsheet function behave differently than when called from code?
(2 answers)
Closed 1 year ago.
I am writing script/code/something to loop through each worksheet in the workbook and it is supposed to get the values from the worksheets that match the criteria. But when I run the function I do not get any value and when I have added MsgBox to see how far the code has gone it doesn't trigger.
I want the code to cycle through each worksheet and then gather the data as coded.
Anyone know what I am doing wrong?
(Also I am new to Stackoverflow so if I need to improve my post in anyway please let me now!)
Function FindBelopp(Month As String, Typ As String) As Double
Dim rng As Range
Dim beloppColumn As Range
Dim lRow As Range
Dim firstAddress As Range
Dim ws As Worksheet
Dim rngAmount As Double
Dim ws_Count As Integer
Dim I As Integer
I = 1
ws_Count = Worksheets.Count
Do While I < ws_Count
Set ws = Worksheets(I)
If InStr(1, ws.Name, Month, 0) > 0 Then
With ws.Cells
Set beloppColumn = .Find("SEK", LookIn:=xlValues)
Set rng = .Find(Typ, LookIn:=xlValues, lookAt:=xlWhole)
If Not rng Is Nothing Then
Set firstAddress = rng
Do
If IsEmpty(rng.Offset(1, 0)) = True Then
Set lRow = Range(Cells(rng.Row, beloppColumn.Column), Cells(rng.End(xlDown)(0).Row, beloppColumn.Column))
Else
Set lRow = Range(Cells(rng.Row, beloppColumn.Column), Cells(rng.Row, beloppColumn.Column))
End If
If Application.Sum(lRow) > 0 Then
rngAmount = Application.Sum(lRow) + rngAmount
Else: End If
Set rng = .FindNext(rng)
Loop While rng.Address <> firstAddress.Address
Else: End If
End With
Else: End If
I = I + 1
Loop
FindBelopp = rngAmount
End Function
First of all.
Thank you for the quick response and for teaching me something new.
The issue was with .FindNext()
I made it work in a similar fashion and it might not be the most efficient use but incase of someone stumbling here with the same issue I thought I could add my now working code.
Function LoopThroughEachSheet(iWantMonths As String, iWantValues As String) As Double
Dim rng As Range
Dim firstAddress As Range
Dim moneyColumn As Range
Dim sumRows As Range
Dim lRow As Range
Dim Money As Double
Dim ws As Worksheet
For Each ws In Worksheets
If InStr(1, _
UCase(ws.Name), _
UCase(iWantMonths)) > 0 Then
With ws.Cells
Set rng = .Find(iWantValues, _
lookAt:=xlWhole, _
LookIn:=xlValues)
If Not rng Is Nothing Then
Set firstAddress = rng
Set moneyColumn = .Find("SEK", _
LookIn:=xlValues, _
lookAt:=xlWhole)
Do
With ws
Set lRow = rng.End(xlDown)(0)
If IsEmpty(rng.Offset(1, 0)) = True Then
Set sumRows = .Range(Cells(rng.Row, moneyColumn.Column).Address, _
Cells(lRow.Row, moneyColumn.Column).Address)
Else
Set sumRows = .Cells(rng.Row, moneyColumn.Column)
End If
End With
Money = Application.Sum(sumRows) + Money
Set rng = .Find(iWantValues, _
After:=rng, _
lookAt:=xlWhole, _
LookIn:=xlValues)
Loop While firstAddress.Address <> rng.Address
Else: End If
End With
Else: End If
Next
LoopThroughEachSheet = Money
End Function
I have the following code and it does what I want it to as far as removing the data I want to remove. The only thing is I have to run it over and over and over for it to get through all of the data. How would I get this to loop over just column q?
Sub SdeleteDeclinesfoReal()
Dim sString As String
Dim MyAr
Dim i As Long
Dim delRange As Range, aCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Add more to the list here separated by "/"
sString = "Declined/Self ACH"
MyAr = Split(sString, "/")
With ws
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(17).Find(What:=MyAr(i), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase :=False, SearchFormat:=False)
If Not aCell Is Nothing Then
If delRange Is Nothing Then
Set delRange = .Rows(aCell.Row)
Else
Set delRange = Union(delRange, .Rows(aCell.Row))
End If
End If
Next i
End With
'...
End Sub
Loop Through Column
A Find Method Solution
Option Explicit
Sub SdeleteDeclinesfoReal()
Const FirstRow As Long = 2
Const CritCol As String = "Q"
Dim Criteria As Variant
'~~> Add more to the list here
Criteria = Array("Declined", "Self ACH")
Dim ws As Worksheet
Dim rng As Range, delRange As Range, aCell As Range
Dim i As Long
Dim sString As String
Dim FirstAddress As String
Set ws = ThisWorkbook.Sheets("Sheet1")
' Define range "Q2:Q1048576" (FirstRow, CritCol).
Set rng = ws.Cells(FirstRow, CritCol).Resize(ws.Rows.Count - FirstRow + 1)
' Define last non-blank cell.
Set rng = rng.Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
' Define 'non-blank' range.
Set rng = ws.Cells(FirstRow, CritCol).Resize(rng.Row - FirstRow + 1)
With rng
For i = LBound(Criteria) To UBound(Criteria)
sString = Criteria(i)
Set aCell = .Find(What:=sString, _
LookAt:=xlWhole)
If Not aCell Is Nothing Then
FirstAddress = aCell.Address
Do
If delRange Is Nothing Then
Set delRange = aCell.EntireRow
Else
Set delRange = Union(delRange, aCell.EntireRow)
End If
Set aCell = .FindNext(aCell)
' Prevent infinite loop caused by the 'FindNext' method.
Loop Until aCell.Address = FirstAddress
Else
' Criteria not found.
End If
' Prevent infinite loop when a criteria is found and one
' of the next is not.
Set aCell = Nothing
Next i
End With
If Not delRange Is Nothing Then
delRange.Select ' Test with 'Select'. Later change to 'Delete'.
Else
' Nothing cell found.
End If
Else
' All cells below first row are blank (empty or "").
End If
End Sub
A Reminder Why to Use Union
Copy the examples into a standard module, e.g. Module1 of a new workbook.
The first two procedures show how to increase efficiency using an array, but are primarily here to better understand what the last three procedures do.
Run the trio each after populating the values, and monitor how long they take and look at the ActiveSheet before and after to see the differences.
Test Union
Option Explicit
' Slow
Sub populateValuesSlow()
Const NoR As Long = 5000
Const NoC As Long = 10
Dim i As Long
Dim j As Long
For i = 1 To NoR
For j = 1 To NoC
Cells(i, j) = Int(Rnd() * (10 - 1)) + 1
Next j
Next i
End Sub
' Fast
Sub populateValuesFast()
Const NoR As Long = 5000
Const NoC As Long = 10
Dim i As Long
Dim j As Long
Dim Data As Variant
ReDim Data(1 To NoR, 1 To NoC)
For i = 1 To NoR
For j = 1 To NoC
Data(i, j) = Int(Rnd() * (10 - 1)) + 1
Next j
Next i
Cells(1, 1).Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
' Wrong: in this case, half of the data still remains.
Sub deleteRowsOneRowAtTheTimeWrong()
Const NoR As Long = 5000
Dim i As Long
For i = 1 To NoR
Rows(i).Delete
Next i
End Sub
' Right but Slow
Sub deleteRowsOneRowAtTheTime()
Const NoR As Long = 5000
Dim i As Long
For i = NoR To 1 Step -1
Rows(i).Delete
Next i
End Sub
' Right and Fast
Sub deleteRowsWithUnion()
Const NoR As Long = 5000
Dim rng As Range
Dim i As Long
For i = 1 To NoR
If Not rng Is Nothing Then
Set rng = Union(rng, Rows(i))
Else
Set rng = Rows(i)
End If
Next i
rng.Delete
End Sub
Well let me describe your scenary:
You have a list in this case your list is
sString = "Declined/Self ACH" (for this example your list have 2 elements)
then you have a table that have at least 17 columns ( Set aCell = .Columns(17).Find) and with your program you search all rows that have in column 17 a value that is in your list then put all that "rows" in a range (delRange) and delete all rows in that range
In this point your code only find firts match for each element in your list so you Range (delRange) have maximum size equal maximum size your list (for this example 2).
OK for me:
Why you save a range with elements that you are going to delete?
you can insert a delete instruction in second loop that others user suggest you, but instead use .Findnext you use another .find
PO=17 /*PO is whatever column you want*/
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(PO).Find(What:=MyAr(i), LookIn:=xlValues)
If Not aCell Is Nothing Then
Do
.Rows(aCell.Row).Delete
Set aCell = .Columns(PO).Find(What:=MyAr(i), LookIn:=xlValues)
Loop While Not aCell Is Nothing
End If
Next i
I am new to VBA... I am trying delete all columns from Sheet1:"Template" ROW1/headers file that doesn't match any of the cell values on varList:"ColumnsList" (that is in Sheet3).
How do I select the headers or how do I select the row 1 range to search into?
Also, I have a runtime error 5 in this line: invalid procedure call or argument.
If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then
Any kind soul that help me with that please?
Also, I need to do the same but with rows from Sheet1:"Template". I need to delete any row that doesn't CONTAIN any cell value from varList:"Agents" (that is in Sheet2).
Could you please help me out?
Maaaany thanks in advance!!!
Option Compare Text
Sub ModifyTICBData()
Dim varList As Variant
Dim lngarrCounter As Long
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
'Application.ScreenUpdating = False
varList = VBA.Array("ColumnsList") 'I want to keep columns with these values, NOT DELETE THEM
For lngarrCounter = LBound(varList) To UBound(varList)
With Sheets("Template").UsedRange
Set rngFound = .Find( _
What:=varList(lngarrCounter), _
Lookat:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngarrCounter
Dim rngDel As Range
Set rngDel = NotIntersectRng(Sheets("Template").UsedRange, rngToDelete)
If Not rngDel Is Nothing Then rngDel.EntireColumn.delete
'Application.ScreenUpdating = True
End Sub
Private Function NotIntersectRng(rng As Range, rngF As Range) As Range
Dim rngNI As Range, i As Long, j As Long
For i = 1 To rng.Columns.Count
**If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then**
If rngNI Is Nothing Then
Set rngNI = rng.Cells(1, i)
Else
Set rngNI = Union(rngNI, rng.Cells(1, i))
End If
End If
Next i
If Not rngNI Is Nothing Then Set NotIntersectRng = rngNI
End Function
Delete Columns, Then Rows
Description
Deletes columns that in the first row do not contain values from a list. Then deletes rows that in the first column do not contain values from another list.
The Flow
Writes the values from range A2 to the last cell in Sheet3 to the Cols Array.
Writes the values from range A2 to the last cell in Sheet2 to the Agents Array.
Using CurrentRegion defines the DataSet Range (rng).
Loops through the cells (cel) in first row starting from the 2nd column and compares their values to the values from the Cols Array. If not found adds the cells to the Delete Range(rngDel).
Finally deletes the entire columns of the cells 'collected'.
Loops through the cells (cel) in first column starting from the 2nd row and compares their values to the values from the Agents Array. If not found adds the cells to the Delete Range(rngDel).
Finally deletes the entire rows of the cells 'collected'.
Informs the user of success or no action.
The Code
Option Explicit
Sub ModifyTICBData()
' Define workbook ('wb').
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Columns List ('Cols').
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet3")
Dim rng As Range
Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
Dim Cols As Variant
Cols = ws.Range("A2", rng).Value
' Define Agents List ('Agents').
Set ws = wb.Worksheets("Sheet2")
Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
Dim Agents As Variant
Agents = ws.Range("A2", rng).Value
' Define DataSet Range ('rng').
Set rng = wb.Worksheets("Template").Range("A1").CurrentRegion
Application.ScreenUpdating = False
' Define Delete Range ('rngDel') for Columns.
Dim rngDel As Range
Dim cel As Range
For Each cel In rng.Rows(1).Resize(, rng.Columns.Count - 1) _
.Offset(, 1).Cells
If IsError(Application.Match(cel.Value, Cols, 0)) Then
collectCells rngDel, cel
End If
Next cel
' Delete Columns.
Dim AlreadyDeleted As Boolean
If Not rngDel Is Nothing Then
rngDel.EntireColumn.Delete
Else
AlreadyDeleted = True
End If
' Define Delete Range ('rngDel') for Agents.
Set rngDel = Nothing
For Each cel In rng.Columns("A").Resize(rng.Rows.Count - 1) _
.Offset(1).Cells
If IsError(Application.Match(cel.Value, Agents, 0)) Then
collectCells rngDel, cel
End If
Next cel
' Delete Agents (Rows).
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
AlreadyDeleted = False
End If
Application.ScreenUpdating = True
' Inform user
If Not AlreadyDeleted Then
MsgBox "The data was succesfully deleted.", vbInformation, "Success"
Else
MsgBox "The data had already been deleted.", vbExclamation, "No Action"
End If
End Sub
Sub collectCells(ByRef CollectRange As Range, CollectCell As Range)
If Not CollectCell Is Nothing Then
If Not CollectRange Is Nothing Then
Set CollectRange = Union(CollectRange, CollectCell)
Else
Set CollectRange = CollectCell
End If
End If
End Sub
I would like to loop all the worksheets of a workbook changing the color of a cell with a specific string in it.
I use .Replace (I need MatchCase and lookat).
It replaces the text without regarding Case. (e.g. if in the array it is lowercase and the string found is uppercase it will be changed to lowercase). The only way to bypass this is to use MatchCase:= false and list all options, and it could be really inefficient.
Could I perform the action using .Find or another function?
Sub CellMarked()
Dim fndlist As Variant, x As Integer, sht as worksheet
fndlist = Array("Column1", "Column2")
For Each sht In ActiveWorkbook.Worksheets
With sht
For x = LBound(fndlist) To UBound(fndlist)
.Cells.Replace What:=fndlist(x), Replacement:=fndlist(x), _
lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, _
SearchFormat:=False, ReplaceFormat:=True
Application.ReplaceFormat.Font.Color = 255
Next x
End With
next sht
End Sub
you could use Find() method and build a helper Function:
Function GetCellsWithValue(sht As Worksheet, val As Variant, foundCells As Range) As Boolean
Dim found As Range
Dim firstAddress As String
With sht.UsedRange
Set foundCells = .Resize(1, 1).Offset(.Rows.Count) ' fill foundCells with a "dummy" found one to avoid 'If Not foundCells Is Nothing' check before any 'Union()' method call
Set found = .Find(what:=val, lookat:=xlPart, LookIn:=xlValues)
If Not found Is Nothing Then
firstAddress = found.Address
Do
Set foundCells = Union(foundCells, found)
Set found = .FindNext(found)
Loop While found.Address <> firstAddress
End If
Set foundCells = Intersect(.Cells, foundCells) ' get rid of the "dummy" found cell
End With
GetCellsWithValue = Not foundCells Is Nothing
End Function
that you could use in your "main" sub as follows:
Option Explicit
Sub CellMarked()
Dim fndlist As Variant, val As Variant, sht As Worksheet
Dim foundCells As Range
fndlist = Array("Column1", "Column2")
For Each sht In ActiveWorkbook.Worksheets
With sht
For Each val In fndlist
If GetCellsWithValue(sht, val, foundCells) Then foundCells.Font.Color = 255
Next
End With
Next sht
End Sub
Find Text Apply Fill
Sub CellMarked()
Dim rngFind As Range, rngU As Range
Dim fndlist As Variant
Dim strFirst As String
Dim i As Integer, x As Integer
fndlist = Array("Column1", "Column2")
For i = 1 To Worksheets.Count
With Worksheets(i)
For x = 0 To UBound(fndlist)
' Check if worksheet has no values.
If Not .Cells.Find("*", .Cells(.Rows.Count, Columns.Count), -4163, 2, 1) _
Is Nothing Then
' Find string.
Set rngFind = .Cells.Find(fndlist(x), _
.Cells(.Rows.Count, Columns.Count))
If Not rngFind Is Nothing Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, rngFind) ' All other occurrences.
Else
Set rngU = rngFind ' First occurrence.
End If
strFirst = rngFind.Address
' Check for other occurrences.
Do
Set rngFind = .Cells.FindNext(rngFind)
If rngFind.Address <> strFirst Then
Set rngU = Union(rngU, rngFind)
Else
Exit Do
End If
Loop
End If
End If
Next
' Apply formatting.
If Not rngU Is Nothing Then
rngU.Interior.Color = 255
' rngU.Font.Color = 255
Set rngU = Nothing
End If
End With
Next
End Sub
Change "strToFind" and try:
Option Explicit
Sub test()
Dim strToFind As String
Dim rng As Range, cell As Range
Dim ws As Worksheet
'String to Find is "Test"
strToFind = "Test"
With ThisWorkbook
For Each ws In .Worksheets
With ws
Set rng = .UsedRange
For Each cell In rng
If cell.Value = strToFind Then
cell.Interior.Color = RGB(255, 0, 0)
End If
Next cell
End With
Next ws
End With
End Sub