Highlight cell that doesn't have only letters - excel

I'm currently trying to develop my first conditional formatting on VBA, but after hours of trial it still doesn't work.
I'm aiming for a formula that would change the background / highlight the text of a cell that contains something else than any alphabet letters (not sensitive to caps or not). Accents, numbers and special characters would be the trigger
Here is my current code
Thank you in advance for your help
Sub Highlight()
Dim MyRange As Range
Set MyRange = Selection
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add xlExpression, , Formula1:="=IsAlpha()=false"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
End Sub
And IsAlpha would be a function like
Function IsAlpha(s) As Boolean
IsAlpha = Len(s) And Not s Like "*[!a-zA-Z ]*"
End Function

You need to pass an argument to IsAlpha. Try the following:
Sub Highlight()
Dim MyRange As Range
Set MyRange = Selection
MyRange.FormatConditions.Delete
Dim s As String
s = "=NOT(IsAlpha(" & MyRange.Cells(1).Address(False, False) & "))"
MyRange.FormatConditions.Add xlExpression, Formula1:=s
MyRange.FormatConditions(1).Interior.Color = vbRed 'Or use RGB...
End Sub
In action:

Highlight Not Pure Alpha
There is a delay of about 2s before the cells get colored (on my machine). I wonder if a worksheet change would handle this smoother (if the range contains values (not formulas)).
Option Explicit
Sub HighlightNotPureAlphaTEST()
If TypeOf Selection Is Range Then
HighlightNotPureAlpha Selection
End If
End Sub
Sub HighlightNotPureAlpha(ByVal rg As Range)
With rg
.FormatConditions.Delete
' To not highlight blanks...
.FormatConditions.Add xlExpression, , _
"=NOT(IsAlphaOrBlank(" & .Cells(1).Address(0, 0) & "))"
' To highlight blanks:
'.FormatConditions.Add xlExpression, , _
"=NOT(IsAlpha(" & .Cells(1).Address(0, 0) & "))"
.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
End With
End Sub
Function IsAlphaOrBlank(ByVal S As String) As Boolean
Application.Volatile
IsAlphaOrBlank = Not S Like "*[!A-Za-z]*"
End Function
Function IsAlpha(ByVal S As String) As Boolean
Application.Volatile
If Len(S) > 0 Then IsAlpha = Not S Like "*[!A-Za-z]*"
End Function

Related

Conditional Formatting a Range row by row

I'm trying to apply some conditionals rules using VBA in a Range.
But I'm very new with conditional formating VBA so I'm a bit lost.
My Users can add rows above of the target range, that mean the range address could be always different.
let's admit that for the exemple, my range is Worksheets("test").Range("MyBoard")
("MyBoard" is my range name, currently located at A19:O32)
How can I apply a rule to turn yellow each rows of my range if the first column contains the value "Customer" ?
Sub FormatRange()
Dim MyRange As Range
Set MyRange = Worksheets("test").Range("MyBoard")
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlCellValue, Formula1:="=COUNTIF(MyRange;"*Customer*") > 0"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End Sub
Thanks for the help
Please, use the next adapted code:
Sub FormatRange()
Dim MyRange As Range, listSep As String
Set MyRange = Range("MyBoard")
listSep = Application.International(xlListSeparator)
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlExpression, formula1:="=ISNUMBER(SEARCH(" & _
"""Customer""" & listSep & MyRange.cells(1, 1).Address(0, 1) & "))"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End Sub
Conditional formatting has some very particular format to get an entire row to work.
E.g., If i want to apply a color to each row, between certain columns of a specified range:
With .Range(.Cells(1, startColumn), .Cells(lastRow, endColumn))
.FormatConditions.Add Type:=xlExpression, Formula1:="=$A1>1"
.FormatConditions(1).Font.Italic = True
End With
Edit1: Indicating use of Find() for the row containing "Customer" being used for the above code.
Sub test()
With Sheets(1)
Dim customerCell As Range: Set customerCell = .Columns(1).Find("Customer")
If customerCell Is Nothing Then Exit Sub
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells.FormatConditions.Delete
With .Range(.Cells(customerCell.Row, 1), .Cells(lastRow, 10))
.FormatConditions.Add Type:=xlExpression, Formula1:="=CountIf($A" & customerCell.Row & ",""*Customer*"")"
.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End With
End With
End Sub
I think, this is what your are looking for:
Sub FormatRange()
Dim MyRange As Range
Set MyRange = Worksheets("test").Range("MyBoard")
Dim startAddress As String
startAddress = MyRange.Cells(1, 1).Address(False, True) ' will return e.g. $A19 in your case
Dim formula As String
'formula = startAddress & " = ""customer""" 'exact customer
formula = "ISNUMBER(FIND(""customer""," & startAddress & "))" ' *customer*
Dim fc As FormatCondition
With MyRange
.FormatConditions.Delete
Set fc = .FormatConditions.Add(xlExpression, Formula1:="=" & formula)
fc.Interior.Color = RGB(255, 255, 0)
End With
End Sub
You have to reference the first cell within your range - and "fix" the column --> .Address(False, True) will return $A19 in your case.
Then you need to build a valid string for the formula to pass to the format condition
You need double quotes for "customer" when building the string.

Get cell formatting

Is there a function to get the activecell formatting? e.g. background color, font, font color, cell border, font size etc.
I want to update the format of an entire worksheet based on a formatted cell before action (i.e. the format I want to change) by another formatted cell (i.e. the format I want to apply).
Sub Rep_all_format()
Dim fmt_bef As CellFormat
Dim fmt_aft As CellFormat
Dim rngReplace As Boolean
Dim msg As String
Dim Sh As Worksheet
Dim Rg As Range
Dim ppos1 As Range
Dim ppos2 As Range
Dim Find As String
Dim Remplace As String
Set ppos1 = Application.InputBox(Prompt:="Select the cell format you wanna change", Title:="Remplace", Default:=ActiveCell.Address, Type:=8)
Set ppos2 = Application.InputBox(Prompt:="Select the cell format you wanna apply", Title:="Select", Type:=8)
Find = ppos1.FormatConditions 'this is theorical I do not know the function
Remplace = ppos2.FormatConditions 'this is theorical I do not know the function
Application.ScreenUpdating = False
Set fmt_bef = Application.FindFormat
Set fmt_aft = Application.ReplaceFormat
For Each Sh In ThisWorkbook.Worksheets
Set Rg = Sh.UsedRange
With fmt_bef
.Clear
.FormatConditions = Find
End With
With fmt_aft
.Clear
.FormatConditions = Remplace
End With
Rg.Replace What:="", Replacement:="", _
SearchFormat:=True, ReplaceFormat:=True
Next
fmt_bef.Clear
fmt_aft.Clear
Application.ScreenUpdating = True
MsgBox ("The desired format has been applied through all the workbook")
End Sub
Assuming, from the code that you have provided, that your cell has been formatted using Conditional Formatting, you need to access is the Range.DisplayFormat property.
Note that I showed only some of the formatting options for a cell. There is documentation online for other formatting options (eg other borders, numberformat, etc) but this should get you started.
For example:
Option Explicit
Sub foo()
Dim R As Range, C As Range
Dim fc As FormatCondition
Set R = Range(Cells(1, 1), Cells(5, 1))
For Each C In R
With C.DisplayFormat
Debug.Print .Interior.Color
Debug.Print .Font.Name
Debug.Print .Font.Color
Debug.Print .Borders(xlEdgeLeft).LineStyle ' etc
Debug.Print .Font.Size
End With
Stop
Next C
End Sub
If the cell has been formatted manually, or directly using code, then just access the various properties directly, not using the DisplayFormat property eg:
For Each C In R
With C
Debug.Print .Interior.Color
Debug.Print .Font.Name
Debug.Print .Font.Color
Debug.Print .Borders(xlEdgeLeft).LineStyle ' etc
Debug.Print .Font.Size
End With
Stop
Next C
What you are looking for are the Range.Interior and Range.Font properties etc.
You can see some examples in the links below:
https://learn.microsoft.com/en-us/office/vba/api/excel.font(object)
https://learn.microsoft.com/en-us/office/vba/api/excel.interior(object)
https://learn.microsoft.com/en-us/office/vba/api/excel.border(object)

Trimming spaces

I'm trying to parse left and right empty spaces, nbsp, \n, \t, etc. from all Excel cells in a certain range.
I'm using the following macro:
Sub TRIM_CELLS()
'Clean all conditional formating
Cells.FormatConditions.Delete
'improve performance
Application.ScreenUpdating = False
Dim all_cells_range As String
all_cells_range = "A1:A10"
'Trim all those cells
Range(all_cells_range).Select
For Each cell In Selection.Cells
cell.Value = Application.Substitute(Application.Substitute(CStr(cell.Value), vbLf, vbCr), vbCr, "")
cell = WorksheetFunction.Trim((Application.Clean(Replace(cell.Value, Chr(160), " "))))
Next cell
End Sub
Something like "Maria Tavares " doesn't get trimmed properly.
#Nick: I tried to use your idea and I think the problem is the char itself... Assuming the following loop works as expected I would get the char that is causing the problem.
Take a look at this image:
But nothing gets printed in that place.
Sub TRIM_CELLS()
'Clean all conditional formating
Cells.FormatConditions.Delete
'improve performance
Application.ScreenUpdating = False
Dim all_cells_range As String
all_cells_range = "A1:A2"
'Trim all those cells
Range(all_cells_range).Select
For Each cell In Selection.Cells
For I = 1 To 255
cell = WorksheetFunction.Substitute(cell, Chr(I), I)
Next I
Next cell
End Sub
I use a function that removes any special characters that you define.
Function RemoveSpecialCharacters(wks As Worksheet, strRange As String, var As Variant)
Dim rngAddress As Range, cell As Range, I&
'e.g strRange - "E2:E"
With wks
Set rngAddress = .Range(strRange & .Cells(Rows.count, "A").End(xlUp).row)
For I = LBound(var) To UBound(var)
For Each cell In rngAddress
cell = WorksheetFunction.Substitute(cell, var(I), " ")
Else
cell = WorksheetFunction.Substitute(cell, var(I), "")
Next cell
Next I
End With
End Function
You could call the function like this:
RemoveSpecialCharacters worksheetname, "A1:A", Array(Chr(9), Chr(10), Chr(13), Chr(39))
Where Chr(10) is linefeed character, chr(9) is the tab character etc.
See this link for what other Chr codes stand for.
UPDATE:
Try this to remove the weird "spy" character from the cell.
RemoveSpecialCharacters worksheetname, "A1:A", Array(Chr(160))
Ended up doing a replacement with that "space"... not a great solution but fixed my problem... Just would like to know what char it was...
Sub TRIM_CELLS()
'Clean all conditional formating
Cells.FormatConditions.Delete
'improve performance
Application.ScreenUpdating = False
Dim all_cells_range As String
all_cells_range = "A1:A2"
Range(all_cells_range).Select
For Each cell In Selection.Cells
cell.Replace What:=" ", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
cell.Value = Application.Substitute(Application.Substitute(CStr(cell.Value), vbLf, vbCr), vbCr, "")
cell.Value = WorksheetFunction.Trim(cell)
Next cell
end sub

Change the Font Color of the Last 3 Digits in a Number

I'm having trouble with some of my code in Excel VBA.
I have an identification number that's always 7 digits long and is located in column B. I need to take the last 3 digits of the ID number and change the font color.
I've tried using the Right() function, but I can't figure out how to combine it with the Font.Color function.
Sub Test
Dim i As Long
For i = 1 To 3
RResult = Right(ActiveCell, 3)
LResult = Left(ActiveCell, 4)
ActiveCell = LResult + " " + RResult
ActiveCell.Offset(1, 0).Select
Next i
End Sub
I tried the above code to seperate the digits, but I can't change the font color of the RResult (Right Result) variable.
This method gives you a few more options:
You pass it the range reference and an optional character count and RGB colour.
Public Sub ColourLastThree(Target As Range, Optional CharCount As Long = 3, Optional RGBColour As Long = 255)
Dim rCell As Range
For Each rCell In Target
If Len(rCell) >= CharCount Then
rCell = "'" & rCell
rCell.Characters(Start:=Len(rCell) - (CharCount - 1), Length:=CharCount).Font.Color = RGBColour
End If
Next rCell
End Sub
You can then call the procedure:
'Colour the last three characters in the ActiveCell to red.
Sub Test()
ColourLastThree ActiveCell
End Sub
'Colour last four characters in Sheet1!A1 to red.
Sub Test1()
ColourLastThree Worksheets("Sheet1").Range("A1"), 4
End Sub
'Colour last four characters in Sheet1!A1 to Green.
Sub Test2()
ColourLastThree Worksheets("Sheet1").Range("A3"), 4, RGB(0, 255, 0) 'or can use 65535 as RGB.
End Sub
'Colour last three character in each cell on the ActiveSheet in A1:A4.
Sub Test3()
ColourLastThree Range("A1:A4")
End Sub
Edit: I've updated the code to cycle through each cell in the passed Target range (as shown in Test3 procedure).
Try the following:
Sub Test
Dim i As Long
For i = 1 To 3
RResult = Right(ActiveCell, 3)
LResult = Left(ActiveCell, 4)
ActiveCell = LResult + " " + RResult
ActiveCell.Characters(Start:=6, Length:=3).Font.Color = 255
ActiveCell.Offset(1, 0).Select
Next i
End Sub

Using "If cell contains" in VBA excel

I'm trying to write a macro where if there is a cell with the word "TOTAL" then it will input a dash in the cell below it. For example:
In the case above, I would want a dash in cell F7 (note: there could be any number of columns, so it will always be row 7 but not always column F).
I'm currently using this code, but it's not working and I can't figure out why.
Dim celltxt As String
Range("C6").Select
Selection.End(xlToRight).Select
celltxt = Selection.Text
If InStr(1, celltext, "TOTAL") > 0 Then
Range("C7").Select
Selection.End(xlToRight).Select
Selection.Value = "-"
End If
Help would be appreciated. Hopefully I'm not doing something stupid.
This will loop through all cells in a given range that you define ("RANGE TO SEARCH") and add dashes at the cell below using the Offset() method. As a best practice in VBA, you should never use the Select method.
Sub AddDashes()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("RANGE TO SEARCH")
For Each cel In SrchRng
If InStr(1, cel.Value, "TOTAL") > 0 Then
cel.Offset(1, 0).Value = "-"
End If
Next cel
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("C6:ZZ6")) Is Nothing Then
If InStr(UCase(Target.Value), "TOTAL") > 0 Then
Target.Offset(1, 0) = "-"
End If
End If
End Sub
This will allow you to add columns dynamically and automatically insert a dash underneath any columns in the C row after 6 containing case insensitive "Total". Note: If you go past ZZ6, you will need to change the code, but this should get you where you need to go.
This does the same, enhanced with CONTAINS:
Function SingleCellExtract(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, Char As String)
Dim I As Long
Dim xRet As String
For I = 1 To LookupRange.Columns(1).Cells.Count
If InStr(1, LookupRange.Cells(I, 1), LookupValue) > 0 Then
If xRet = "" Then
xRet = LookupRange.Cells(I, ColumnNumber) & Char
Else
xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
End If
End If
Next
SingleCellExtract = Left(xRet, Len(xRet) - 1)
End Function
Dim celltxt As String
Range("C6").Select
Selection.End(xlToRight).Select
celltxt = Selection.Text
If InStr(1, celltext, "TOTAL") > 0 Then
Range("C7").Select
Selection.End(xlToRight).Select
Selection.Value = "-"
End If
You declared "celltxt" and used "celltext" in the instr.
Is this what you are looking for?
If ActiveCell.Value == "Total" Then
ActiveCell.offset(1,0).Value = "-"
End If
Of you could do something like this
Dim celltxt As String
celltxt = ActiveSheet.Range("C6").Text
If InStr(1, celltxt, "Total") Then
ActiveCell.offset(1,0).Value = "-"
End If
Which is similar to what you have.
Requirement:
Find a cell containing the word TOTAL then to enter a dash in the cell below it.
Solution:
This solution uses the Find method of the Range object, as it seems appropriate to use it rather than brute force (For…Next loop).
For explanation and details about the method see Range.Find method (Excel)
Implementation:
In order to provide flexibility the Find method is wrapped in this function:
Function Range_ƒFind_Action(sWhat As String, rTrg As Range) As Boolean
Where:
sWhat: contains the string to search for
rTrg: is the range to be searched
The function returns True if any match is found, otherwise it returns False
Additionally, every time the function finds a match it passes the resulting range to the procedure Range_Find_Action to execute the required action, (i.e. "enter a dash in the cell below it"). The "required action" is in a separated procedure to allow for customization and flexibility.
This is how the function is called:
This test is searching for "total" to show the effect of the MatchCase:=False. The match can be made case sensitive by changing it to MatchCase:=True
Sub Range_Find_Action_TEST()
Dim sWhat As String, rTrg As Range
Dim sMsgbdy As String
sWhat = "total" 'String to search for (update as required)
Rem Set rTrg = ThisWorkbook.Worksheets("Sht(0)").UsedRange 'Range to Search (use this to search all used cells)
Set rTrg = ThisWorkbook.Worksheets("Sht(0)").Rows(6) 'Range to Search (update as required)
sMsgbdy = IIf(Range_ƒFind_Action(sWhat, rTrg), _
"Cells found were updated successfully", _
"No cells were found.")
MsgBox sMsgbdy, vbInformation, "Range_ƒFind_Action"
End Sub
This is the Find function
Function Range_ƒFind_Action(sWhat As String, rTrg As Range) As Boolean
Dim rCll As Range, s1st As String
With rTrg
Rem Set First Cell Found
Set rCll = .Find(What:=sWhat, After:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Rem Validate First Cell
If rCll Is Nothing Then Exit Function
s1st = rCll.Address
Rem Perform Action
Call Range_Find_Action(rCll)
Do
Rem Find Other Cells
Set rCll = .FindNext(After:=rCll)
Rem Validate Cell vs 1st Cell
If rCll.Address <> s1st Then Call Range_Find_Action(rCll)
Loop Until rCll.Address = s1st
End With
Rem Set Results
Range_ƒFind_Action = True
End Function
This is the Action procedure
Sub Range_Find_Action(rCll)
rCll.Offset(1).Value2 = Chr(167) 'Update as required - Using `§` instead of "-" for visibilty purposes
End Sub

Resources