Change font color for a row of text in cell which contains a certain value - excel

I am writing a check in/out program in excel and have gotten te request that if a line contains "|0|" it should get a different font color.
I've tried with Instr and Cells().Characters but I cannot seem to figure out how to do it.
The cells can have a variety of rows of text. Which is easy enough to solve with splitting them on a return and having a for loop loop, but I cannot seem to figure out how to assign a different font color to a row of text that contains the required value.
Image for illustration of the data:
How do I best solve this?
Added information:
The goal of this is that on button press the whole line of text where the |O| is would be collored differently. Other lines of text that do not have this will remain the same color.
Like in this image as a concept
[]

try this
Public Sub ExampleMainSub()
Dim cell As Range
For Each cell In Selection
If HasMySymbols(cell.Value) Then
WorkWithCellContent cell
Else
cell.Font.ColorIndex = xlAutomatic
cell.Font.TintAndShade = 0
End If
Next cell
End Sub
Private Sub WorkWithCellContent(ByVal cell As Range)
Dim arr As Variant
arr = Split(cell.Value, Chr(10))
Dim firstPosOfRow As Long
firstPosOfRow = 1
Dim subLine As Variant
For Each subLine In arr
If HasMySymbols(subLine) Then
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.Color = vbRed
Else
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.ColorIndex = xlAutomatic
End If
firstPosOfRow = firstPosOfRow + Len(subLine) + 1 '+1 is needed
Next subLine
End Sub
Private Function HasMySymbols(ByVal somestring As String) As Boolean
HasMySymbols = InStr(1, somestring, "|0|") > 0
End Function

Try this. It works for me.
Sub ChangeRowFontColour()
Dim rng As Range
Dim TextToFind As String
Dim FirstFound As String
TextToFind = "Specific Text"
With ActiveSheet.UsedRange
Set rng = .Cells.Find(TextToFind, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstFound = rng.Address
Do
rng.EntireRow.Font.ColorIndex = 3
For Each part In rng
lenOfPart = Len(part)
lenTextToFind = Len(TextToFind)
For i = 1 To lenOfPart
tempStr = Mid(part, i, lenTextToFind)
If tempStr = TextToFind Then
part.Characters(Start:=i, Length:=lenTextToFind).Font.ColorIndex = 0
End If
Next i
Next
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstFound
End If
End With
End Sub

Related

VBA loop until next bold and uppercase value

I have a file called tg. I'd like to loop through the column A and everytime I come across an uppercase bold value, I'd like to store it as a key of my dictionary pp. The item associated is a collection of all the values up until the next uppercase and bold value. And repeat. My code doesn't seem to produce anything. Any help would be appreciated.
EDIT: I tested the my code with:
MsgBox (Pairs.Items(0).Count) and I get 0.
Function Pairs() As Dictionary
Call Files
With tg
Dim rng As Range
Dim pp As New Dictionary
Dim item As Variant
Dim arr
Dim gp As Variant
Set arr = New Collection
For Each rng In .Range("A1:A50")
If Not IsEmpty(rng) And IsUpper(rng.Value) And rng.Value <> "NULL" And rng.Font.Bold = True Then
gp = rng.Value
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
pp.Add gp, arr
End If
Next rng
Set Pairs = pp
End With
End Function
Please, use the next faster way. It find the first Bolded cell, checks if isUpper and place in a dictionary (as key) the matched such cells value and the range in between as item:
Function Pairs() As Scripting.Dictionary
Dim tg As Worksheet, rng As Range, cB As Range, firstAddress As String, pp As New Scripting.Dictionary
Set tg = ActiveSheet 'use here the sheet you need
Set rng = tg.Range("A1:A50")
With Application.FindFormat
.Clear
.Font.Bold = True
End With
Set cB = rng.Find(what:=vbNullString, Searchformat:=True)
Dim prevRow As Long, prevKey As String
If Not cB Is Nothing Then
If IsUpper(cB.value) Then
firstAddress = cB.Address:
Do
If prevRow <> 0 Then Set pp(prevKey) = tg.Range("A" & prevRow & ":A" & cB.row - 1)
pp.Add cB.value, 1: prevRow = cB.row: prevKey = cB.value
Do
Set cB = rng.Find(what:=vbNullString, After:=cB, Searchformat:=True)
Loop Until IsUpper(cB.value)
Loop While cB.Address <> firstAddress
End If
Set pp(prevKey) = tg.Range("A" & prevRow & ":A50")
Else
MsgBox "No bolded cell in Uppercase has been found..."
End If
Set Pairs = pp
End Function
Function IsUpper(s) As Boolean
With CreateObject("VBScript.RegExp")
.Pattern = "^[^a-z]*$"
IsUpper = .test(s)
End With
End Function
It can be tested with something like:
Sub testPairs()
Dim i As Long, pp As Scripting.Dictionary
Set pp = Pairs
If pp.count = 0 Then Exit Sub
For i = 0 To pp.count - 1
Debug.Print pp.Keys()(i), pp.Items()(i).Address
Debug.Print Join(Application.Transpose(pp.Items()(i).value), "|")
Next i
End Sub
For the last occurrence it uses the range starting below it and the last cell in the range. If you will not use something static ("A1:A50"), the calculated last cell can be used...
If you need/want a collection instead of range as a dictionary item, it can be done, but in the way I tried handling the processing the range looks the most appropriate. You can easily place the range in an array and do whatever you need with it...
Please, send some feedback after testing it.
Your loop starting with Do While Not IsEmpty(rng) needs an incrementation, otherwise will exit immediately in case of a match but will stay in a continuous loop if not...
If you like more your way, or want better understanding where the mistake is, please replace this part:
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
Firstly a new variable should be declared `Dim i As Long`.
Then replace with:
Do
arr.Add rng.Offset(i).value
i = i + 1
Loop Until IsUpper(rng.Offset(i).value) And rng.Offset(i).Font.Bold = True Or rng.Offset(i).value = ""
i = 0
Do is not oK use If, and a problem in For.
For Each rng In .Range("A1:A50").Cells

Change color of cells if the value matches values of other worksheets values in a column

So here's the code. I have a calendar with dates in B4:H9. I want to change the color of the cells if the those dates are in a list (column, on different worksheet).
This might be a bit heavy to run if there are many different dates in the worksheet, but that doesn't matter.
What am I doing wrong here? It keeps giving me different error codes, when trying different things.
Sub check_Click()
Dim area As Range
Dim item1 As Range
Dim item2 As Range
Dim sheet As Worksheet
Dim columnlist As Range
sheet = Range("E2").Value
area = Range("B4:H9")
columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
For Each item1 In area
For Each item2 In columnlist
If item1.Value = item2.Value Then
item1.Interior.ColorIndex = RGB(255, 255, 0)
End If
Next item2
Next item1
End Sub
As SuperSymmetry mentioned, when you define objects (e.g. ranges, sheets) you need to use the Set keyword. I will not get into that explanation. However few things that I would like to mention...
Try and give meaningful variable names so that you can understand what are they for.
Work with objects so that your code knows which sheet, which range are you referring to.
No need of 2nd loop. Use .Find to search for your data. It will be much faster
To set RGB, you need .Color and not .ColorIndex
Is this what you are trying? (Untested)
Option Explicit
Sub Check_Click()
Dim rngData As Range
Dim rngReference As Range
Dim aCell As Range
Dim matchedCell As Range
Dim ws As Worksheet
Dim lastRow As Long
Dim worksheetName As String
'~~> Change the sheet name accordingly
worksheetName = ThisWorkbook.Sheets("Sheet1").Range("E2").Value
Set ws = ThisWorkbook.Sheets(worksheetName)
With ws
'~~> Find the last row in Col A
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngData = .Range("B4:H9")
Set rngReference = .Range("A2:A" & lastRow)
'~~> Loop through your data and use .Find to check if the date is present
For Each aCell In rngData
Set matchedCell = rngReference.Find(What:=aCell.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not matchedCell Is Nothing Then
'~~> Color the cell
matchedCell.Interior.Color = RGB(255, 255, 0)
End If
Next aCell
End With
End Sub
This should do the trick, I don't like leaving ranges without their sheet, but since I believe you are using a button, there should be no problem:
Option Explicit
Sub check_Click()
'We are going to use a dictionary, for it to work you need to:
'Go to Tools-References-Check the one called: Microsoft Scripting Runtime
Dim DatesToChange As Dictionary: Set DatesToChange = LoadDates
Dim area As Range: Set area = Range("B4:H9")
Dim item As Range
For Each item In area
If DatesToChange.Exists(item.Value) Then
item.Interior.Color = RGB(255, 255, 0)
End If
Next item
End Sub
Private Function LoadDates() As Dictionary
Set LoadDates = New Dictionary
Dim arr As Variant: arr = ThisWorkbook.Sheets(Range("E2")).Range("A:A")
Dim i As Long
For i = 2 To UBound(arr)
'This here will break the loop when finding an empty cell in column A
If arr(i, 1) = vbNullString Then Exit For
'This will add all your dates in a dictionary (avoiding duplicates)
If Not LoadDates.Exists(arr(i, 1)) Then LoadDates.Add arr(i, 1), 1
Next i
End Function
When you define objects (e.g. ranges, sheets) you need to use the Set keyword
Set area = Range("B4:H9")
Set columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
Worksheets() accepts either an Integer or a String. Therefore, sheet should be of Type String
Dim sheet As String
You're also setting columnlist to the whole column in the sheet so you're looping hundreds of thousands more times unncessarily. Change it to
With Worksheets(sheet)
Set columnlist = .Range(.Range("A2"), .Range("A" & Rows.Count).Offset(xlUp))
End With
The above should fix the errors in your code and make it run a little faster. However, there's still big room for improvment in the efficiency of the code. For example, instead of changing the colour inside the loop, you should build a range and set the colour one time after the loop.
Also consider resetting the colour at the beginning of the code with
area.Interior.Pattern = xlNone
I would personally go with conditional formatting as #SiddharthRout suggested in the comments.
Edit following comment
Here's my rendition
Sub check_Click()
Dim dStart As Double
dStart = Timer
Dim rngCalendar As Range
Dim vCalendar As Variant
Dim shtDates As Worksheet
Dim vDates As Variant, v As Variant
Dim i As Long, j As Long
Dim rngToColour As Range
' Change the sheet name
With ThisWorkbook.Sheets("Calendar")
Set rngCalendar = .Range("B4:H9")
vCalendar = rngCalendar.Value
Set shtDates = ThisWorkbook.Sheets(.Range("E2").Value)
End With
With shtDates
vDates = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
End With
For i = 1 To UBound(vCalendar, 1)
For j = 1 To UBound(vCalendar, 2)
For Each v In vDates
If v <> vbNullString And v = vCalendar(i, j) Then
If rngToColour Is Nothing Then
Set rngToColour = rngCalendar.Cells(i, j)
Else
Set rngToColour = Union(rngToColour, rngCalendar.Cells(i, j))
End If
Exit For
End If
Next v
Next j
Next i
rngCalendar.Interior.Pattern = xlNone
If Not rngToColour Is Nothing Then
rngToColour.Interior.Color = RGB(255, 255, 0)
End If
MsgBox "Time taken: " & Format(Timer - dStart, "0.0000s")
End Sub
With a list of 2500 dates it took 0.0742s on my machine.

Select a hyperlink in one column based on "X" in adjacent column

So I'm fairly new to VBA, and I have been struggling with trying to get my macro to work.
Essentially what I'm trying to do is have a program read down a column, and for every "X" located in that column, the corresponding hyperlink in the adjacent column will be selected.
Sub Select_Hyperlinks()
Dim rng As Range, cell As Range, sel As Range
Dim sht As Worksheet
For x = 1 To 6
Set sht = Sheets("Generator")
Set sel = cell.Offset(-1, 0)
Set rng = Intersect(sht.Range("D4:D9"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) <> "X" _
Then
If sel Is Nothing Then
Set sel = cell.Offset(-1, 0)
sel.Select
End If
Next cell
End If
Next x
End Sub
I also tried a simpler idea using the Find and FindNext functions and for each X, I tried to get it to select and activate the cell in the adjacent column, but also with no luck. It seems I always get snagged up on the .Offset function.
EDIT:
Here's what I've managed to come up with, after some further research. I've adapted this from a macro designed to delete all empty rows.
Sub AutoOpen()
Dim xlastcell As Integer
Dim xcell As Integer
xcell = 1
Range("C200").End(xlUp).Select
xlastcell = ActiveCell.Cells 'This used to say ActiveCell.Row but I want a single cell'
Do Until xcell = xlastcell
If Cells(xcell, 1).Value = "X" Then
Cells(x, 1).Select
ActiveCell.Offset(0, -1).Select 'I'm also unable to get this function to work'
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
xcell = xcell - 1
xlastcell = xlastcell - 1
End If
xcell = xcell + 1
Loop
End Sub
Are you saying that if there is an X in the one column, you want to open the hyperlink?
EDIT:
Use this and change things to match your variables.
Sub asdhkl()
Dim c As Hyperlink
Dim i As Range
For Each i In Sheets(1).Range("b1:b3")
If i = "x" Then
Set c = i.Offset(0, -1).Hyperlinks(1)
c.Follow
End If
Next i
End Sub

VBA to convert texts to numbers except formula and non-numeric texts

I have a Range("B6:T10000")
Data in the range are a mixture of blanks,#'s ,numbers (formatted as texts), texts and most importantly formulas.
Can someone please help with a VBA macro to:
Find anything that looks like number and convert it to number
Ignore the rest
Don't convert formulas to values
Thank you very much
You can do this without code, or with quicker code avoiding loops
Manual
Copy a blank cell
Select your range B6:T100001
Press F5. Then Goto ... Special
check Constants and then Text
Paste Special Multiply and check Add
This converts text only cells with numbers into numbers, and leaves actual text or formulae alone
Code
Sub Update()
Dim rng1 As Range
On Error Resume Next
Set rng1 = Range("B6:T10000").SpecialCells(xlCellTypeConstants, 2)
On Error Resume Next
If rng1 Is Nothing Then Exit Sub
'presumes last cell in sheet is blank
Cells(Rows.Count, Columns.Count).Copy
rng1.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End Sub
here's my version:
Sub Test()
Dim rng as Range, cel as Range
Set rng = Thisworkbook.Sheets("Sheet1").Range("B6:T10000")
For Each cel In rng
If Not IsError(cel.Value) Then _
If Len(cel.Value) <> 0 And cel.HasFormula = False And _
IsNumeric(cel.Value) Then cel.Value = Val(cel.Value)
Next cel
End Sub
I've tested it, and works fine.
Hope this helps.
Give this a try:
Sub Converter()
Dim rBig As Range, r As Range, v As Variant
Set rBig = Range("B6:T10000")
For Each r In rBig
v = r.Value
If v <> "" And r.HasFormula = False Then
If IsNumeric(v) Then
r.Clear
r.Value = v
End If
End If
Next r
End Sub
EDIT#1:
This version ignores errors:
Sub Converter()
Dim rBig As Range, r As Range, v As Variant
Set rBig = Range("B6:T10000")
For Each r In rBig
v = r.Value
If Not IsError(v) Then
If v <> "" And r.HasFormula = False Then
If IsNumeric(v) Then
r.Clear
r.Value = v
End If
End If
End If
Next r
End Sub
ActiveSheet.Range("b5:b6004,h5:h6004").Select
For Each xCell In Selection
If IsNumeric(xCell) = False Then
xCell.Value = Val(xCell.Value)
Else
End If
Next xCell

excel custom function

I have this table that contain more than 6K rows.
I need a function, that will run on each "A" Column's cell
and check -> if cell on "b" is bold than copy it,
if not, copy the cell above it.
I fount this function on the internet, but im not using VB and it will be easier if someone that already know how to use VB functions in excel than learn it from the beginning.
this code replaces the G column cells with numbers, as you can see.
Sub BoldCells()
Dim TheRange As Range
Dim TheCell As Range
Set TheRange = Range("G1", Range("G65536").End(xlUp))
For Each TheCell In TheRange
If TheCell.Font.Bold = True Then
TheCell = 7
Else: TheCell = 0
End If
Next TheCell
End Sub
Help will be very appreciated, thank you!
I am not sure how efficient this is, but looks like working with 10 lines or so of data.
Sub test()
Dim rng As Range, str As String
Set rng = Range("b1")
str = ""
Do
If rng.Font.Bold Then
str = rng.Value
End If
rng.Offset(0, -1).Value = str
Set rng = rng.Offset(1, 0)
Loop Until IsEmpty(rng)
End Sub

Resources