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
Related
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
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 want to break up this line of code, to make it more digestible, in smaller steps, but I am running in problems that I either get compile errors, run time errors, or just plain the wrong response.
As a beginner in coding of VBA, maybe somebody enlightens me, why it is not possible, or if it is possible where I am going wrong with my approach.
This code is functional snippet is below, but the function following is not
Dim WksN As String
Dim res As Object
' Set res = Sheets("Sheet3").Cells(1, 1).EntireRow.Find(What:=name
Set res = Sheets(WksN).Cells(1, 1).EntireRow.Find(What:=name _
, LookIn:=xlValues _
, LookAt:=xlPart _
, SearchOrder:=xlByColumns _
, SearchDirection:=xlPrevious _
, MatchCase:=False)
Public Function GetColumnNumber(ByVal WksN As String, _
ByVal name As String) As Long
Dim wks As Worksheet
Dim rng As Range
Dim res As Object
Dim clmn As Object
' Set wks = ActiveWorkbook.Worksheets(CStr(WksN))
' Set wks = Sheets(CStr(WksN))
' Set wks = Sheets(CStr(WksN)).Activate
' Set wks = ActiveWorkbook.Worksheets(CStr(WksN)).Activate
Set wks = ActiveWorkbook.Worksheets(CStr(WksN)) '
' Set rng = wks.Cells(1, 1).EntireRow.Select ' Run time error
' Set rng = wks.Activate ' Not needed ??
' Set rng = wks.Rows(1).Select ' Compile error
Set rng = wks.Rows(1)
' With wks.Cells(1, 1).EntireRow ' Didn't work
With rng
Set clmn = .Find(What:=name, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End With
If res Is Nothing Then
GetColumnNumber = 0
Else
GetColumnNumber = clmn.Column
End If
End Function
I would like to set the range of the entire first row and then
search and find the column in which my string is stored.
I am not sure if the statement from above is atomic and can't be broken up,
or how I am not activating or selecting the "right" range, as the return value of this function is zero when the return value of the first code snippet is none zero and correct.
The second question I have that I seem not to select the range when I am using the .Rows(1) statement, which strikes me that I must fundamentally not understand how this is supposed to work.
Set rng = wks.Cells(1, 1).EntireRow.Select ' Run time error
Select does not return a value, so don't use that if you're trying to get a reference to a range
Set rng = wks.Cells(1, 1).EntireRow
This should work:
Public Function GetColumnNumber(ByVal WksN As String, _
ByVal hdr As String) As Long
Dim f As Range
Set f = ActiveWorkbook.Worksheets(WksN).Rows(1).Find( _
what:=hdr, LookIn:=xlValues, lookat:=xlPart)
If f Is Nothing Then
GetColumnNumber = 0
Else
GetColumnNumber = f.Column
End If
End Function
I have created a Do Loop with Find to replace "Hello" with "Hi" inside column A of Sheet1, but only if the string "XYZ" is not in the same row of column B.
When Find does not replace "Hello", because in column B there is "XYZ", we enter an infinite loop since FindNext always finds "Hello" in column 1
It is possible to avoid infinite loop without making Loop While very complicated?
Please see this image of columns in sheet1
Sub CallMask()
Call Masks("Hello", "XYZ")
End Sub
Sub Masks(sMask_I As String, sNoReplace_I As String)
With Sheets("Sheet1").Columns(1)
Dim CellToReplace As Range
Set CellToReplace = .Find(What:=sMask_I, LookIn:=xlValues, _
SearchDirection:=xlNext, MatchCase:=True, Lookat:=xlPart)
If Not CellToReplace Is Nothing Then
Dim InitialAddress As String
InitialAddress = CellToReplace.Address
Dim MaskRow As Long
Dim Mask As String
On Error Resume Next
Do
MaskRow = WorksheetFunction.Match(sMask_I, _
Sheets("Sheet1").Range("C1:C" & Rows.Count), 0)
Mask = Sheets("Sheet1").Range("D" & MaskRow).Value2
If Sheets("Sheet1").Cells(CellToReplace.Row, 2) <> sNoReplace_I Then
CellToReplace.Value2 = Replace(CellToReplace.Value2, sMask_I, Mask)
End If
Set CellToReplace = .FindNext(CellToReplace)
Loop While Not CellToReplace Is Nothing And CellToReplace.Address _
<> InitialAddress
On Error GoTo 0
End If
End With
End Sub
You could try this:
Option Explicit
Sub CallMask()
Call Masks("Hello", "XYZ", "Hi")
End Sub
Sub Masks(sMask_I As String, sNoReplace_I As String, Replacement As String)
Dim C As Range
With ThisWorkbook.Sheets("Sheet1")
For Each C In .Range("A1", "A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If C Like "*" & sMask_I & "*" And C.Offset(0, 1) <> sNoReplace_I Then
C.Replace sMask_I, Replacement
End If
Next C
End With
End Sub
When using Find() in a loop it's typically easier to abstract that out into a separate method:
Sub CallMask()
Masks "Hello", "XYZ"
End Sub
Sub Masks(sMask_I As String, sNoReplace_I As String)
Dim matches As Collection, c
Set matches = FindAll(Sheets("Sheet1").Columns(1), sMask_I)
For Each c In matches
If c.Offset(0, 1) <> sNoReplace_I Then
c.Value = Replace(c.Value, sMask_I, c.Offset(0, 3).Value)
End If
Next c
End Sub
'return all matches as a collection
Public Function FindAll(rng As Range, val As String) 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.Count), _
LookIn:=xlValues, LookAt:=xlPart, 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 have tested with arrays as suggested by Damian, AJD and Mathieu. It is the fastest code.
Times for 1600 rows are:
My new code with arrays: 8 ms
Damian code with For Next: 132 ms
The Code with "separate method" of Tim Williams: 402 ms
My first code with Find: 511 ms
This is the new code:
Sub CallMask()
Call Masks("Hello", "XYZ")
End Sub
Sub Masks(ByVal sMask_I As String, ByVal sNoReplace_I As String)
With ThisWorkbook.Sheets("Sheet1")
Dim ArrayRangeToMask As Variant
ArrayRangeToMask = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
Dim MaskRow As Long
Dim Mask As String
MaskRow = WorksheetFunction.Match(sMask_I, .Range("C1:C" & Rows.Count), 0)
Mask = .Range("D" & MaskRow).Value2
Dim RowMasking As Long
For RowMasking = 1 To UBound(ArrayRangeToMask)
If InStr(ArrayRangeToMask(RowMasking, 1), sMask_I) And _
ArrayRangeToMask(RowMasking, 2) <> sNoReplace_I Then
ArrayRangeToMask(RowMasking, 1) = _
Replace(ArrayRangeToMask(RowMasking, 1), sMask_I, Mask)
End If
Next RowMasking
.Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row) = ArrayRangeToMask
End With
End Sub