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
Related
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 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
I have this macro to replace special characters in any sheet in my workbook.
It gets rid of these characters: ! # # $ % ^ & () /
Sub Macro3()
Dim splChars As String
Dim ch As Variant
Dim splCharArray() As String
splChars = "! # # $ % ^ & () /" splCharArray = Split(splChars, " ")
For Each ch In splCharArray
Cells.Replace What:="~" & ch, Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=True
Next ch
End Sub
I need a second macro which would do Cells.Find for every cell in every worksheet then create a new sheet to list all cell addresses and special characters found.
On the web I found:
Public Sub SearchForText()
Dim rngSearchRange As Range
Dim vntTextToFind As Variant
Dim strFirstAddr As String
Dim lngMatches As Long
Dim rngFound As Range
On Error GoTo ErrHandler
vntTextToFind = Application.InputBox( _
Prompt:="Enter text to find:", _
Default:="Search...", _
Type:=2 _
)
If VarType(vntTextToFind) = vbBoolean Then Exit Sub
On Error Resume Next
Set rngSearchRange = Application.InputBox( _
Prompt:="Enter range for search:", _
Default:=ActiveCell.Parent.UsedRange.Address, _
Type:=8 _
)
On Error GoTo ErrHandler
If rngSearchRange Is Nothing Then Exit Sub
Set rngFound = rngSearchRange.Find( _
What:=CStr(vntTextToFind), _
LookIn:=xlValues, _
LookAt:=xlPart _
)
If rngFound Is Nothing Then
MsgBox "No matches were found.", vbInformation
Else
With ThisWorkbook.Sheets.Add
With .Range("A1:B1")
.Value = Array("Cell", "Value")
.Font.Bold = True
End With
strFirstAddr = rngFound.Address
Do
lngMatches = lngMatches + 1
.Cells(lngMatches + 1, "A").Value = rngFound.Parent.Name & "!" _
& rngFound.Address(0, 0)
.Cells(lngMatches + 1, "B").Value = rngFound.Value
Set rngFound = rngSearchRange.FindNext(rngFound)
Loop Until (rngFound.Address = strFirstAddr)
.Columns("A:B").AutoFit
End With
End If
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub
This code works. My problem is, I need to set a range in which it searches every time and it can only be one sheet, so essentially if I have 10 sheets I need to run this macro 10 times to get the desired result.
I would like to search for each character in every worksheet of my workbook, then create a new sheet and return the address of every cell in an entire workbook which contains any of my declared characters.
I thought I could declare new variable ws as worksheet and loop through all worksheets with the same range selected using for each.
Try this. You just need another loop for the worksheets, and a loop for the Find.
This code doesn't do any replacing.
Sub Macro3()
Dim splChars As String
Dim ch As Variant
Dim splCharArray() As String
Dim r As Range, s As String
Dim ws As Worksheet
splChars = "! # # $ % ^ & () /"
splCharArray = Split(splChars, " ")
Sheets.Add().Name = "Errors" 'to list characters and location
For Each ch In splCharArray
For Each ws In Worksheets
If ws.Name <> "Errors" Then
Set r = ws.Cells.Find(What:=ch, Lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False)
If Not r Is Nothing Then
s = r.Address
Do
Sheets("Errors").Range("A" & Rows.Count).End(xlUp)(2) = ch 'character
Sheets("Errors").Range("B" & Rows.Count).End(xlUp)(2) = r.Address(external:=True)
Set r = ws.Cells.FindNext(r)
Loop Until r.Address = s 'loop until we are back to the first found cell
End If
End If
Next ws
Next ch
End Sub
I am trying to build a macro which will find a column with the header "Total Labor" and delete all rows which have "0" in that column. I am generating multiple reports and the "Total Labor" column will change position so that's why I need the find. So far I have this code but when I run it nothing happens. Any help is appreciated.
Sub DeleteRows()
Dim FoundCell As Range
Dim rng As Range
Application.ScreenUpdating = False
Set rng = Worksheets(ActiveSheet.Name).Range("A1:BB100").Find(what:="Total Labor", _
LookAt:=xlWhole, MatchCase:=False)
Set FoundCell = rng.Find(what:="0")
Do Until FoundCell Is Nothing
FoundCell.EntireRow.Delete
Set FoundCell = rng.FindNext
Loop
End Sub
First: if you set Application.ScreenUpdating = False be sure that you reset it to True before the sub ends. If your macro crashes you could find yourself unable to work with the application until you restart Excel or run another macro that sets Application.ScreenUpdating = True
Now, to answer your question: The problem with your code is that rng as defined in your code is only going to be the cell containing "Total Labor". When you search for a value of "0" in that range, the line Set FoundCell = rng.Find(what:="0") evaluates to "Nothing", so when you start the do loop, it meets the criterion of FoundCell Is Nothing and immediately goes to End Sub.
Something like this should do the trick:
Sub DeleteRows2()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
'~~>dim variables and set initial values
Dim rTotalLaborHeader As Range
Set rTotalLaborHeader = Worksheets(ActiveSheet.Name).Range("A1:BB100").Find(what:="Total Labor", _
LookAt:=xlWhole, MatchCase:=False)
Dim rTotalLaborColumn As Range
Set rTotalLaborColumn = Range(Cells(2, rTotalLaborHeader.Column), Cells(1048576, rTotalLaborHeader.Column).End(xlUp))
'Set rTotalLaborColumn = Range(rTotalLaborHeader.Offset(1, 0), rTotalLaborHeader.End(xlDown))
Dim rLaborRow As Range
'~~>Loop to delete rows with zero Total Labor
For Each rLaborRow In rTotalLaborColumn
If rLaborRow.Value = 0 Then rLaborRow.EntireRow.Delete
Next rLaborRow
CleanupAndExit:
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
Resume CleanupAndExit
End Sub
How about:
Sub DeleteRow()
Dim colly As Long, killer As Range, nRow As Long
colly = 0
For i = 1 To Columns.Count
If Cells(1, i).Value = "Total Labor" Then
colly = i
Exit For
End If
Next i
If colly = 0 Then
MsgBox "Header not found"
Exit Sub
End If
nRow = Cells(Rows.Count, colly).End(xlUp).Row
For i = 1 To nRow
If Cells(i, colly).Value = 0 Then
If killer Is Nothing Then
Set killer = Cells(i, colly)
Else
Set killer = Union(killer, Cells(i, colly))
End If
End If
Next i
If killer Is Nothing Then
Else
killer.EntireRow.Delete
End If
End Sub
You need to replicate the FindAll functionality that the Excel UI Provides. Here's a code-list for achieving that in VBA. Save this to a .bas file, then call it in your macro after you locate 'Total Labor' and then look through the range you get back from FindAll and execute .Delete on them.
Sub DeleteRows()
Dim FoundCell As Range
Dim rng As Range
Application.ScreenUpdating = False
Set rng = Worksheets(ActiveSheet.Name).Range("A1:BB100").Find(what:="Total Labor", _
LookAt:=xlWhole, MatchCase:=False)
If rng Is Nothing Then
Msgbox "Total Labor Not Found"
Else
Set SearchRange = rng.EntireColumn
FindWhat = "0"
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
FoundCell.EntireRow.Delete
Next FoundCell
End If
End If
End Sub
FindAll Source Code: http://www.cpearson.com/excel/findall.aspx
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
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.