I'm writing a Sub that finds all instances of the word "uM" in a single cell and change the font to blue. Here's a picture of what I want the code to do, and what my code outputs.
Here's my code:
Sub Highlight_uM()
Dim WS As Worksheet
Dim Attention As Range
Dim Cell As Range
Dim Counter As Integer
Set WS = ActiveWorkbook.ActiveSheet
Set Attention = WS.Cells.Find(What:="Attention", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Find Attention range
For Each Cell In Attention
For Counter = 1 To Len(Cell)
If Cell.Characters(Counter, 1).Text = "u" Then
Cell.Characters(Counter, 1).Font.ColorIndex = 42
End If
Next
Next Cell
End Sub
As you can see from my code, it only selects .Text = "u". If I change it to = "uM", the sub doesn't do anything. Any tips on how to amend my code to highlight every instance of the entire word "uM" in the cell?
You can use this code:
Sub highlightCellCharacters()
Range("C1").Select
Dim rng As Range
Set rng = Range("C1:C6")
For Each Cell In rng
Dim Counter As Integer
For Counter = 1 To Len(Cell)
If Cell.Characters(Counter, 2).Text = "uM" Then
Cell.Characters(Counter, 2).Font.ColorIndex = 3
End If
Next
ActiveCell.Offset(1, 0).Select
Next Cell
End Sub
This will work for cells C1 to C6
Related
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
I've been struggling with this for a while now.
A1:O7 are frozen columns.
Only the Column A contains trigger values that I find using
Dim Cell As Range
Columns("A:A").Select
Set Cell = Selection.Find(What:="BANK:", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
After that I need to expand the selection so that all the rows and the columns to the right and down from the cell found until the next cell to be found are copied and split into a separate file along with the frozen columns A1:O7 at the top. The range is A7:Oxxxx. There is no data beyond the O column.
Is there a solution to this without using any Excel add-ons?
I tried to understand the task. There are some information missing so this solution might not exactly fitting your needs. I hope it will work for you.
Private Sub Bank()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Bank") 'change according to your workingsheet
Dim rngHeader As Range
Set rngHeader = ws.Range("A1:O7")
Dim iWidth As Integer 'Data and header width
iWidth = rngHeader.Columns.Count
Dim strSearchText As String
strSearchText = "BANK:"
Dim rngSearchArea As Range
Set rngSearchArea = ws.Range(Range("A7"), ws.Range("A" & ws.Range("A:A").Cells.Count).End(xlUp))
Dim strFirstFound As String
Dim rngCurrentFound As Range
Set rngCurrentFound = ws.Range("A7")
Set rngCurrentFound = rngSearchArea.Find(What:=strSearchText, After:=rngCurrentFound, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If rngCurrentFound Is Nothing Then
MsgBox "Nothing found"
Exit Sub
End If
strFirstFound = rngCurrentFound.Address
Dim rngSource As Range
Dim rngNextFound As Range
Do
'Get the position of the next occurence to set the end position
Set rngNextFound = rngSearchArea.FindNext(rngCurrentFound)
If rngNextFound.Row > rngCurrentFound.Row Then
'There is next one
Set rngSource = Range(rngCurrentFound, rngNextFound.Offset(-1)).Resize(, iWidth)
Else
'It was the last one
'If there are data in column A below the last BANK: use the next line
'Set rngSource = ws.Range(rngCurrentFound, Cells(ws.Range("A" & ws.Range("A:A").Cells.Count).End(xlUp), iWidth))
'Use this one to select until the last used cell in the worksheet
Set rngSource = ws.Range(rngCurrentFound, ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
End If
'rngSource.Select
Call Bankcopy(rngSource, rngHeader)
Set rngCurrentFound = rngSearchArea.FindNext(rngCurrentFound)
Loop While rngCurrentFound.Address <> strFirstFound
End Sub
Private Sub Bankcopy(rngSource As Range, ByVal rngHeader As Range)
'Create new book and copy headers
Dim wbNewBook As Workbook
Set wbNewBook = Workbooks.Add()
Dim wsNewSheet As Worksheet
Set wsNewSheet = wbNewBook.Worksheets(1)
Dim rngTarget As Range
'Copy header
Set rngTarget = wsNewSheet.Range("A1") 'To header left upper
rngHeader.Copy
rngTarget.PasteSpecial xlPasteValues
rngTarget.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'Copy data
Set rngTarget = wsNewSheet.Range("A8") 'Data left upper
rngSource.Copy
rngTarget.PasteSpecial xlPasteValues
rngTarget.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'MsgBox "Test Stop"
'wbNewBook.Close
End Sub
I have a code that searches for a value in another shett, after searching i want to copy what the original sheet has bellow in another cells, but i want to oly copy what has information. Then return to the value found and paste bellow last cell with information.
In the sample code the partida.value was found in sheets("bancos") cell = H6
I want to copy the info in Sheets("Bu") B7:C19 and its supposed to get pasted bellow sheets("bancos") G13:h13
Private Sub C1_Click()
Dim Partida As String
Dim Rng As Range
Partida = Worksheets("BU").Range("c3").Value
If Trim(Partida) <> "" Then
With Sheets("Bancos").Rows("6:6")
Set Rng = .Find(What:=Partida, after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Rng Is Nothing Then
Worksheets("Bu").Activate
ActiveSheet.Range("b7:c19").Select
'i want to copy only the filled cells in the range (b7:c19); the filled cells in b and c
Selection.Copy
Application.Goto Rng, True
'I want to paste in the last cells with information within the right and below cells from the "rng" found in cells G and H
Else
MsgBox "Not found"
End If
End With
End If
End Sub
No error msg tho
Can you try this. It's untested, but should get you close at least.
Private Sub C1_Click()
Dim Partida As String
Dim Rng As Range, r1 As Range, r As Long, c As Long
Partida = Worksheets("BU").Range("c3").Value
If Trim(Partida) <> "" Then
With Sheets("Bancos").Rows("6:6")
Set Rng = .Find(What:=Partida, after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Rng Is Nothing Then
r = Rng.Row + 4
c = Rng.Column - 1
For Each r1 In Worksheets("Bu").Range("b7:c19")
If Len(r1) > 0 Then
.Cells(r, c + r1.Column - 2).Value = r1.Value
r = r + 1
End If
Next r1
Else
MsgBox "Not found"
End If
End With
End If
End Sub
I got little project in VBA and stuck on below topic.
I need to select range from searched value to first empty cell in H column.
Selected range should looks like this
Selected Range in Excel:
I searched for specific value in column A and if I found it it's being set as first cell in range. ( It works)
Then I need to find last cell in range which is first empty cell in last column.
This is what I've found and try to use
Sub Button()
Dim StringToFind As String
StringToFind = Application.InputBox("Enter string to find", "Find string")
Worksheets("SS19").Activate
ActiveSheet.Range("A:A").Select
Set cell = Selection.Find(What:=StringToFind, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
cell.Select
With Worksheets("SS19")
Set rr = .Range(ActiveCell, .Cells(.Rows.Count, "H").End(xlUp))
With rr
rr.Parent.Range(.Cells(1, "A"), .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0)).Select
End With
End With
If cell Is Nothing Then
Worksheets("SS19").Activate
MsgBox "String not found"
End If
I tried to searched for first empty cell in prevously selected range so it won't search the whole column but it doesn't work.
Try this...
Dim StringToFind As String
StringToFind = Application.InputBox("Enter string to find", "Find string")
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
With ws
Dim findCel As Range
Set findCel = .Range("A:A").Find(StringToFind, , , xlWhole, , , False, , False)
Dim lRow As Long
lRow = .Range(findCel.Address).Offset(, 7).End(xlDown).Row + 1
Dim rr As Range
Set rr = .Range("A" & findCel.Row & ":" & "H" & lRow)
rr.Select
End With
I find that using the worksheet's match function is easier than Range.Find when searching a single column.
Option Explicit
Sub Button()
Dim stringToFind As String, m As Variant
Worksheets("SS19").Activate
stringToFind = Application.InputBox("Enter string to find", "Find string", Type:=xlTextValues)
With Worksheets("SS19")
m = Application.Match(stringToFind, .Range("A:A"), 0)
If Not IsError(m) Then
If Not IsEmpty(.Cells(m + 1, "H")) Then
.Range(.Cells(m, "A"), .Cells(m, "H").End(xlDown).Offset(1)).Select
Else
.Range(.Cells(m, "A"), .Cells(m, "H").Offset(1)).Select
End If
End If
End With
End Sub
Using .End(xlDown) could be problematic if the first cell under row m in column H was blank and this should be checked for or you might find the selection reaching too far, possibly all the way down to the bottom of the worksheet. Checking for a non-blank cell will catch this potential problem.
I am working on a project and I have got a point where I want to copy certain data from one sheet to another. E.g. if in column "A" a cell contains "Hello" then copy what is in cell "E4". Would an "IF" statement would work?
The code I have so far for my project is
Sub testfortito()
Dim x As Workbook
Dim y As Workbook
Dim ws As Worksheet
'this opens both workbooks
Set x = Workbooks.Open("Location1")
Set y = Workbooks.Open("Location2")
'to do the copy
x.Sheets("sheet3").Range("A2:AC2").Copy
For Each ws In Worksheets
If ws.Name <> "sheet3" Then
ws.Range("E3").Copy
Worksheets ("Sheet3")
End If
Next ws
End Sub
Try this
Sub testfortito()
Dim colEtxt(), ctr
ctr = 0
With Sheet1.Range("A:A")
Set txt = .Find(What:="hello", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not txt Is Nothing Then
firstAddress = txt.Address
Do
ReDim Preserve colEtxt(ctr)
colEtxt(ctr) = Range(txt.Address).Offset(0, 4).Value
Set txt = .FindNext(txt)
ctr = ctr + 1
Loop While Not txt Is Nothing And txt.Address <> firstAddress
End If
End With
'copy the array onto sheet2 using transpose technique
Sheet2.Range("A1:A" & UBound(colEtxt) + 1) = WorksheetFunction.Transpose(colEtxt)
End Sub