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
Related
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
Hi I'm having an issue with filtering an excel sheet. Basically I'm extracting a very long pdf to excel.
From the data exported I'm only interested in some codes that come in the form of SM12345 (SM and five numbers).
I was able to create a formula in excel to check for 3 conditions I defined to filter the data but it only check on a single cell value(I can't seem to find how to refer to the whole sheet as range, as in the search function).
My idea is to use advance filtering and use my 3 conditions as criteria but I don't know how to refer to the whole sheet in excel, so then I record a macro and copy those in a separate column.
My conditions are:
1- Contains "SM"
2- The length is 7 (though I think I could use wild characters after SM, not sure)
3- The string contains numbers
This is the excel formula I have for a single cell:
=IF(AND(ISNUMBER(SEARCH("sm",A9)),LEN(A9)=7,COUNT(FIND({0,1,2,3,4,5,6,7,8,9},A9))>0),A9,"")
First find all SM* and select them all with ctrl+a in the find box as shown in the image. After closing the find box all the cells will remain selected and then you can run the following macro. Then you can do anything with those cells looping myRng.
Sub SlectCond()
Dim myRng As Range
For Each cell In Selection
If HasNumber(cell.Value) And Len(cell) >= 7 Then
If myRng Is Nothing Then
Set myRng = cell
Else
Set myRng = Union(myRng, cell)
End If
End If
Next
For Each cell In myRng
cell.Interior.ColorIndex = 6
Next
End Sub
Function HasNumber(strData As String) As Boolean
Dim iCnt As Integer
For iCnt = 1 To Len(strData)
If IsNumeric(Mid(strData, iCnt, 1)) Then
HasNumber = True
Exit Function
End If
Next iCnt
End Function
Or if you want to execute all through a macro........
Sub SlectCond()
Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)).Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Dim myString, myStringArr
myString = ""
Dim myRng As Range
For Each cell In Selection
If HasNumber(cell.Value) And InStr(1, cell.Value, "SM") And Len(cell) >= 7 Then
If myRng Is Nothing Then
Set myRng = cell
myString = cell.Value
Else
Set myRng = Union(myRng, cell)
myString = myString & "," & cell.Value
End If
End If
Next
For Each cell In myRng
cell.Interior.ColorIndex = 6
Next
myStringArr = Split(myString, ",")
Worksheets.Add
For i = 0 To UBound(myStringArr)
Range("A" & i + 1) = myStringArr(i)
Next
End Sub
Function HasNumber(strData As String) As Boolean
Dim iCnt As Integer
For iCnt = 1 To Len(strData)
If IsNumeric(Mid(strData, iCnt, 1)) Then
HasNumber = True
Exit Function
End If
Next iCnt
End Function
I would like to change the color of a text in a cell in MS Excel like the conditioned formatting. I have different text in one cell, e.g. "WUG-FGT" or "INZL-DRE". I would like to format the cells (all cells in my workshhet), that a defined text like "WUG-FGT" appears red and the other text "INZL-DRE" green, but the text is in the same cell. With "sandard" conditioned formatting I only get the backgroud coloured.
A similar questions is this: How can I change color of text in a cell of MS Excel?
But the difference is that I (actually) don't work with programming. That means that I need a more simple or easy solution to implement this in my excel file.
Is this possible? A solution with VBA would also be possible, I know how to implement them.
here example how you can achieve required results:
Sub test()
Dim cl As Range
Dim sVar1$, sVar2$, pos%
sVar1 = "WUG-FGT"
sVar2 = "INZL-DRE"
For Each cl In Selection
If cl.Value2 Like "*" & sVar1 & "*" Then
pos = InStr(1, cl.Value2, sVar1, vbTextCompare)
cl.Characters(pos, Len(sVar1)).Font.Color = vbRed
End If
If cl.Value2 Like "*" & sVar2 & "*" Then
pos = InStr(1, cl.Value2, sVar2, vbTextCompare)
cl.Characters(pos, Len(sVar2)).Font.Color = vbGreen
End If
Next cl
End Sub
test
UPDATE
Is it possible to count how often the word has been detected. Either to write to total amount to a defined cell or what also would be great, to add the number of counts in brackets behind the word with an control variable? So in your example: A2: "WUG-FGT(1)", A4: "WUG-FGT(2)", A5: "WUG-FGT(3)"
Yes, but you should update the cell before colorizing, otherwise whole cell font will be colorized by the first char's color (e.g. cell contains both keywords and first is red, and second is green, after update whole cell font will be red). See updated code and test bellow:
Sub test_upd()
Dim cl As Range, sVar1$, sVar2$, pos%, cnt1%, cnt2%
Dim bVar1 As Boolean, bVar2 As Boolean
sVar1 = "WUG-FGT": cnt1 = 0
sVar2 = "INZL-DRE": cnt2 = 0
For Each cl In Selection
'string value should be updated before colorize
If cl.Value2 Like "*" & sVar1 & "*" Then
bVar1 = True
cnt1 = cnt1 + 1
cl.Value2 = Replace(cl.Value, sVar1, sVar1 & "(" & cnt1 & ")")
End If
If cl.Value2 Like "*" & sVar2 & "*" Then
bVar2 = True
cnt2 = cnt2 + 1
cl.Value2 = Replace(cl.Value, sVar2, sVar2 & "(" & cnt2 & ")")
End If
pos = InStr(1, cl.Value2, sVar1, vbTextCompare)
If bVar1 Then cl.Characters(pos, Len(sVar1)).Font.Color = vbRed
pos = InStr(1, cl.Value2, sVar2, vbTextCompare)
If bVar2 Then cl.Characters(pos, Len(sVar2)).Font.Color = vbGreen
bVar1 = False: bVar2 = False
Next cl
End Sub
test
Change Format of Parts of Values in Cells
Links
Workbook Download
Image
The Code
'*******************************************************************************
Sub CFF(Range As Range, SearchString As String, _
Optional ColorIndex As Long = -4105, _
Optional OccurrenceFirst0All1 As Long = 1, _
Optional Case1In0Sensitive As Long = 1)
' ColorIndex
' 3 for Red
' 10 for Green
' OccurrenceFirst0All1
' 0 - Only First Occurrence of SearchString in cell of Range.
' 1 (Default) - All occurrences of SearchString in cell of Range.
' Case1In0Sensitive
' 0 - Case-sensitive i.e. aaa <> AaA <> AAA
' 1 (Default) - Case-INsensitive i.e. aaa = AaA = AAA
Const cBold As Boolean = False ' Enable Bold (True) for ColorIndex <> -4105
Dim i As Long ' Row Counter
Dim j As Long ' Column Counter
Dim rngCell As Range ' Current Cell Range
Dim lngStart As Long ' Current Start Position
Dim lngChars As Long ' Number of characters (Length) of SearchString
' Assign Length of SearchString to variable.
lngChars = Len(SearchString)
' In Range.
With Range
' Loop through rows of Range.
For i = .Row To .Row + .Rows.Count - 1
' Loop through columns of Range.
For j = .Column To .Column + .Columns.Count - 1
' Assign current cell range to variable.
Set rngCell = .Cells(i, j)
' Calculate the position of the first occurrence
' of SearchString in value of current cell range.
lngStart = InStr(1, rngCell, SearchString, Case1In0Sensitive)
If lngStart > 0 Then ' SearchString IS found.
If OccurrenceFirst0All1 = 0 Then ' FIRST occurrence only.
GoSub ChangeFontFormat
Else ' ALL occurrences.
Do
GoSub ChangeFontFormat
lngStart = lngStart + lngChars
lngStart = InStr(lngStart, rngCell, SearchString, _
Case1In0Sensitive)
Loop Until lngStart = 0
End If
'Else ' SearchString NOT found.
End If
Next
Next
End With
Exit Sub
ChangeFontFormat:
' Font Formatting Options
With rngCell.Characters(lngStart, lngChars).Font
' Change font color.
.ColorIndex = ColorIndex
' Enable Bold for ColorIndex <> -4105
If cBold Then
If .ColorIndex = -4105 Then ' -4105 = xlAutomatic
.Bold = False
Else
.Bold = True
End If
End If
End With
Return
End Sub
'*******************************************************************************
Real Used Range (RUR)
'*******************************************************************************
' Purpose: Returns the Real Used Range of a worksheet.
' Returns: Range Object or "Nothing".
'*******************************************************************************
Function RUR(Optional NotActiveSheet As Worksheet) As Range
Dim objWs As Worksheet
If Not NotActiveSheet Is Nothing Then
Set objWs = NotActiveSheet
Else
Set objWs = ActiveSheet
End If
If objWs Is Nothing Then Exit Function
Dim HLP As Range ' Cells Range
Dim FUR As Long ' First Used Row Number
Dim FUC As Long ' First Used Column Number
Dim LUR As Long ' Last Used Row Number
Dim LUC As Long ' Last Used Column Number
With objWs.Cells
Set HLP = .Cells(.Cells.Count)
Set RUR = .Find("*", HLP, xlFormulas, xlWhole, xlByRows)
If Not RUR Is Nothing Then
FUR = RUR.Row
FUC = .Find("*", HLP, , , xlByColumns).Column
LUR = .Find("*", , , , xlByRows, xlPrevious).Row
LUC = .Find("*", , , , xlByColumns, xlPrevious).Column
Set RUR = .Cells(FUR, FUC) _
.Resize(LUR - FUR + 1, LUC - FUC + 1)
End If
End With
End Function
'*******************************************************************************
Usage
The following code if used with the Change1Reset0 argument set to 1, will change the format in each occurrence of the desired strings in a case-INsensitive search.
'*******************************************************************************
Sub ChangeStringFormat(Optional Change1Reset0 As Long = 0)
Const cSheet As Variant = "Sheet1"
Const cStringList As String = "WUG-FGT,INZL-DRE"
Const cColorIndexList As String = "3,10" ' 3-Red, 10-Green
' Note: More strings can be added to cStringList but then there have to be
' added more ColorIndex values to cColorIndexList i.e. the number of
' elements in cStringList has to be equal to the number of elements
' in cColorIndexList.
Dim rng As Range ' Range
Dim vntS As Variant ' String Array
Dim vntC As Variant ' Color IndexArray
Dim i As Long ' Array Elements Counter
Set rng = RUR(ThisWorkbook.Worksheets(cSheet))
If Not rng Is Nothing Then
vntS = Split(cStringList, ",")
If Change1Reset0 = 1 Then
vntC = Split(cColorIndexList, ",")
' Loop through elements of String (ColorIndex) Array
For i = 0 To UBound(vntS)
' Change Font Format.
CFF rng, CStr(Trim(vntS(i))), CLng(Trim(vntC(i)))
Next
Else
For i = 0 To UBound(vntS)
' Reset Font Format.
CFF rng, CStr(Trim(vntS(i)))
Next
End If
End If
End Sub
'*******************************************************************************
The previous codes should all be in a standard module e.g. Module1.
CommandButtons
The following code should be in the sheet window where the commandbuttons are created, e.g. Sheet1.
Option Explicit
Private Sub cmdChange_Click()
ChangeStringFormat 1
End Sub
Private Sub cmdReset_Click()
ChangeStringFormat ' or ChangeStringFormat 0
End Sub
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
Dim StartPosWUG As Long, StartPosINL As Long
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
For Each cell In rng
StartPosWUG = InStr(1, cell, "WUG-FGT")
StartPosINL = InStr(1, cell, "INZL-DRE")
If StartPosWUG > 0 Then
With cell.Characters(Start:=StartPosWUG, Length:=Len("WUG-FGT")).Font
.Color = vbRed
End With
End If
If StartPosINL > 0 Then
With cell.Characters(Start:=StartPosINL, Length:=Len("INZL-DRE")).Font
.Color = vbGreen
End With
End If
Next
End With
End Sub
I need to compare two values and highlight the difference if any.
The below snippet is saying equal or not but along with that I need to highlight the values.
Cells contains a list of string values.
Public Sub Overview_LRF()
If (Range("L2").Value = Range("L5").Value) Then
Gazellevalidation2.OverviewProjects.Value = "Equals"
Else
Gazellevalidation2.OverviewProjects.Value = "Not Equals"
End If
End Sub
Sub HighlightDuplicateValues()
Dim myRange As Range
Dim myCell As Range
Set myRange = Selection
For Each myCell In myRange
If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 36
End If
Next myCell
End Sub
On the same lines, made a macro to find difference in two cells by checking character by character. Some times this kind of situations do occur, where we need to find out the difference by character.
Paste data in adjacent columns, like col A, Col B
Data in Col A and B will be same like A1="David",B1="Davi1d", with a difference.
Select first column and run the macro
Macro will check thecell and the adjacent cell and highlight the difference.
Sub ChkDiff()
i = ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
Set myRange = Selection
For Each Cell In myRange
L1 = Len(Cell.Value)
L2 = Len(Cell.Offset(0, 1).Value)
If L1 > L2 Then
LENT = L1
Else
LENT = L2
End If
'Cells(j, ActiveCell.Column).Select
For x = 1 To LENT
v1 = Cell.Characters(1, x).Text
v2 = Cell.Offset(0, 1).Characters(1, x).Text
If v1 <> v2 Then
Cell.Characters(x, 1).Font.Color = VBA.RGB(255, 0, 0)
End If
Next x
Next
End Sub
See this example below:
Option Explicit
Sub main()
Dim in1 As Range
Dim in2 As Range
Dim out As Range
Dim i As Long
Dim iLen As Long
Set in1 = Cells(1, 1)
Set in2 = Cells(1, 2)
Set out = Cells(1, 3)
If in1.Value2 = in2.Value2 Then
out = "<identical>"
Else
out.Value2 = vbNullString
iLen = Len(in1.Value2)
For i = 1 To iLen ' find the 1st mismatch
If in1.Characters(i, 1).Text <> in2.Characters(i, 1).Text Then Exit For
Next i
If i <= iLen Then
out.Value2 = in1.Value2
Else
out.Value2 = in2.Value2
iLen = Len(in2.Value2)
End If
out.Characters(i, iLen - i + 1).Font.Color = vbRed
' you can make it more robust here
' handling nullstring output or space char
End If
End Sub
If you need more sophisticated comparison, you might consider Fuzzy Lookup Add-In for Excel.
I want to run a macro on selected cells - where the macro compares a cell to it's neighbor beneath him - changes their color and moves on to the next pair of cells.
it's A 1 dimension array where I want to compare each pair of cells (1st with the 2nd, 3rd with the 4th etc.)
I tried working with
For Each cell In Selection
but then I don't know how to compare the given cell to the one beneath it.
Below is the sample code.
Sub compare()
Dim rng As Range, cell As Range
Set rng = Selection '
For Each cell In rng
'makes comparison
'offset(1,0) is used to find one cell below active cell
If cell.Value = cell.Offset(1, 0) Then
cell.Offset(1, 0).Interior.Color = vbRed
End If
Next
End Sub
Updated answer
Sub compare()
Dim rows As Long
rows = Selection.rows.Count - 1
Dim selCol As Long
selCol = ActiveCell.Column
Dim selRow As Long
selRow = ActiveCell.Row
For i = selRow To (selRow + rows)
If Cells(i, selCol) = Cells(i, selCol + 1) Then
Range(Cells(i, selCol), Cells(i, selCol + 1)).Interior.Color = vbYellow
End If
Next
End Sub
Sub compareCells()
Dim i As Integer
'Check dimension
If Selection.Columns.Count <> 1 Then
MsgBox "not 1d array"
Exit Sub
End If
'Check size
If Selection.Rows.Count Mod 2 <> 0 Then
MsgBox "size not even"
Exit Sub
End If
For i = 1 To Selection.Count / 2
With Selection
If .Cells(2 * i - 1) = .Cells(2 * i) Then
'what you want to do here, for e.g. , change color
.Cells(2 * i).Interior.Color = vbYellow
Else
'what you want to do here
'MsgBox "neq"
End If
End With
Next i
End Sub