excel vba: make part of string bold - excel

I have excel cells which contain entries like this:
name/A/date
name/B/date
name/C/date
Cell content is displayed on multiple lines in the same cell. I would like to make only "name" bold for all entries. I recorded a macro and I think the solution must be something like this:
ActiveCell.FormulaR1C1 = "name/A/date" & Chr(10) & "name/B/date" & Chr(10) & "name/C/date"
With ActiveCell.Characters(Start:=25, Length:=4).Font
.FontStyle = "Bold"
End With
What I don't know is how to get the start value and the length of each entry. Anyone got an idea?

Have it now:
lngPos = InStr(ActiveCell.Value, "/")
With ActiveCell.Characters(Start:=1, Length:=lngPos - 1).Font
.FontStyle = "Bold"
End With

Inspired by various research in the last few days:
Dim totalVals, startPos(), endPos(), i, j, strLen As Long
Dim currLine As String
' Split the cell value (a string) in lines of text
splitVals = Split(ActiveCell.Value, Chr(10))
' This is how many lines you have
totalVals = UBound(splitVals)
' For each line, you'll have a character where you want the string to start being BOLD
ReDim startPos(0 To totalVals)
' And one character where you'll want it to stop
ReDim endPos(0 To totalVals)
' The value of the current line (before we loop on ActiveCell.Value) is empty
currLine = ""
For i = 0 To totalVals ' For each line...
' Length of the string currently treated by our code : 0 if no treatment yet...
strLen = Len(currLine)
' Here we parse and rewrite the current ActiveCell.Value, line by line, in a string
currLine = currLine & IIf(currLine = "", "", Chr(10)) & splitVals(i)
' At each step (= each line), we define the start position of the bold part
' Here, it is the 1st character of the new line, i.e. strLen + 1
startPos(i) = strLen + 1
' At each step (= each line), we define the end position of the bold part
' Here, it is just before the 1st "/" in the current line (hence we start from strLen)
endPos(i) = InStr(IIf(strLen = 0, 1, strLen), currLine, "/")
Next i
' Then we use the calculated positions to get the characters in bold
For j = 0 To UBound(startPos)
ActiveCell.Characters(startPos(j), endPos(j) - startPos(j)).Font.FontStyle = "Bold"
Next j
It might be a bit overdone, butI have tested it and it works like a charm. Hope this helps!

The answers above are perfectly fine. Since its related I wanted to include a similar routine I wrote to solve a formatting thing in my wife's macros.
in her situation we were consolidating string and wrote the concatenation into a single cell separated by a vbCrLf (Chr(10)) in her final output it would look something like this
Category number 1:
Category # 2:
Category 3:
The length of each category was different, and the # of categories may vary from 1 cell to the next. The pasted subroutine worked great
Sub BoldCategory()
RowCount = ActiveSheet.UsedRange.Rows.Count
Set MyRange = ActiveSheet.Range(Cells(2, 1), Cells(RowCount, 1))
For Each Cell In MyRange
i = 1
LineBreak = 1
Do While LineBreak <> 0
EndBoldPoint = InStr(i, Cell.Value, ":") + 1
BoldLength = EndBoldPoint - i
Cell.Characters(Start:=i, Length:=BoldLength).Font.FontStyle = "Bold"
LineBreak = InStr(i, Cell.Value, Chr(10))
i = LineBreak + 1
Loop
Next Cell
End Sub
So the ":" was the character I was keying in on to get the end point. the Chr(10) told me when 1 line ended and the next line began. When the last line was reached instr returned 0 therefore the while loop exits.

Related

vba remove comma without removing strikethough

How am I able to remove the comma without removing the strikethrough format
Example: C418, C419, C420 , C421, C422, C423, C424
Expected Result: C418 C419 C420 C421 C422 C423 C424
Final Result: C418, C419 C420 C421 C422 C423 C424
I am checking to see if that cell contain a strikethrough. By using the Function I am able to detect it. But once I try to remove the comma by using the replace function and replace comma with a blank. The format for the strikethrough will be remove causing the function not to work which will result in a different outcome.
I will like to use the space delimiter to match with the other cell so that I can split the cell value afterwards
If HasStrikethrough(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB)) = True Then
BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value = Replace(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value, ",", "")
BOMCk.Sheets("Filtered RO BOM").Range("G" & LCB).Value = "strike-off"
ElseIf HasStrikethrough(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB)) = False Then
BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value = Replace(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value, ",", "")
End If
Function HasStrikethrough(rng As Range) As Boolean
Dim i As Long
With rng(1)
For i = 1 To .Characters.Count
If .Characters(i, 1).Font.StrikeThrough Then
HasStrikethrough = True
Exit For
End If
Next i
End With
End Function
Range.Characters only works if the cells value is 255 characters or less.
Range.Characters(i, 1).Delete will delete the commas. Make sure to iterate from the last position to the first position when deleting.
Sub RemoveCommas(ByVal Target As Range)
If Target.Characters.Count > 255 Then
MsgBox "Range.Characters only works with String with 255 or less Characters", vbCritical, "String too long"
Exit Sub
End If
Dim n As Long
For n = Target.Characters.Count To 1 Step -1
If Target.Characters(n, 1).Text = "," Then Target.Characters(n, 1).Delete
Next
End Sub
Alternative via xlRangeValueXMLSpreadsheet Value
The ►.Value(11) approach solves the question by a very simple string replacement (though the xml string handling can reveal to be very complicated in many other cases):
Sub RemoveCommata(rng As Range, Optional colOffset As Long = 1)
'a) Get range data as xml spreadsheet value
Dim xmls As String: xmls = rng.Value(xlRangeValueXMLSpreadsheet) ' //alternatively: xmls = rng.Value(11)
'b) find start position of body
Dim pos As Long: pos = InStr(xmls, "<Worksheet ")
'c) define xml spreadsheet parts and remove commata in body
Dim head As String: head = Left(xmls, pos - 1)
Dim body As String: body = Replace(Mid(xmls, pos), ",", "")
'd) write cleaned range back
rng.Offset(0, colOffset).Value(11) = head & body
End Sub
Help reference links
Excel XlRangeValueDataType enumeration
Excel Range Value

Usage of WorksheetFunction.Trim in Excel VBA is removing coloring in cell

I'm developing in VBA Excel and I discovered that I use WorksheetFunction.Trim(Cells(1,1)) where this cells contain any colored element, this element become colored by default.
Here is my code:
Cells(4, 2) = Application.WorksheetFunction.Trim(UCase(Cells(4, 2)))
Did you see this issue before ?
How can I remove blank in the text without this issue ?
Thanks for your help !
For cells with mixed formatting, replacing the cell value will lose the mixed format: instead you need to work with the cell's Characters collection:
Sub tester()
Dim c As Range
For Each c In Range("B3:B10").Cells
TrimAndUppercase c
Next c
End Sub
Sub TrimAndUppercase(c As Range)
Dim i, prevSpace As Boolean
If Len(c.Value) > 0 Then
'trim the ends of the text
Do While Left(c.Value, 1) = " "
c.Characters(1, 1).Text = ""
Loop
Do While Right(c.Value, 1) = " "
c.Characters(Len(c.Value), 1).Text = ""
Loop
'reduce runs of multiple spaces to a single space
For i = c.Characters.Count To 1 Step -1
With c.Characters(i, 1)
If .Text = " " Then
'was the previous character a space?
If prevSpace Then
.Text = "" 'remove this space
Else
prevSpace = True
End If
Else
.Text = UCase(.Text)
prevSpace = False
End If
End With
Next i
End If
End Sub
Note there are some limits to the length of the text using this method, and it can be a little slow with large ranges.
finally, I used this instruction.
Cells(4, 2) = Replace(UCase(Cells(4, 2)), " ", "")
In fact, my cell contain parameters and we perfers to avoid to have blank between them for visibility.

Excel - VBA : How do I replace the last 3 characters if they are "..."

Please could you help me a little bit? I am a complete beginner, I don't know anything about programming.
I have the following code that changes double spaces into single spaces and deletes "..." if it's at the beginning of the selected cell(s).
Sub Test()
Dim X As Long, Cell As Range
For Each Cell In Selection
For X = Len(Cell.Text) To 1 Step -1
If Cell.Characters(X - 1, 2).Text = " " Then Cell.Characters(X, 1).Text = ""
If Cell.Characters(1, 3).Text = "..." Then Cell.Characters(1, 3).Text = ""
Next
Next
End Sub
Please could you tell me how I could change the part If Cell.Characters(1, 3).Text so that it removes "..." if it's at the end of the selected cell(s)?
This is not that easy as may seem, since Excel has the inclination to adjust three dots into an ellipsis, making it a single character that's unrecognizable when compared to a dot (or three). Furthermore, you don't need to loop characters 1 by 1, instead you could use Like to check if a cell is ending with the three dots, or rather the ellipsis. Next to that, we can trim excessive space characters in a Range in one go, using Application.Trim() as shown here.
So let's look at example data like:
Then if we select this Range and go over its cells using, for example:
Sub Test()
Dim cl As Range
For Each cl In Selection
If cl.Value Like "*..." Then
cl.Value = Left(cl.Value, Len(cl.Value) - 3)
ElseIf cl.Value Like "*" & ChrW(8230) Then
cl.Value = Left(cl.Value, Len(cl.Value) - 1)
End If
Next
Selection.Value = Application.Trim(Selection)
End Sub
The results would then be:
And for the sake of fun alternatives, a RegEx approach:
Sub Test2()
Dim cl As Range
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "…$|\.{3}$"
For Each cl In Selection
cl.Value = .Replace(cl.Value, "")
Next
End With
Selection.Value = Application.Trim(Selection)
End Sub
Maybe this can help you: Use the replace methode to change two spaces into one space. To search for three points at the beginning use the left methode and if it's the case, cut it out with the right methode. Here you have to watch out. Excel often replace three point by the character 133. So you have additional to test for it.
Sub Test()
Dim cell As Range
For Each cell In Selection
cell.Value = Replace(cell.Value, " ", " ")
If Left(cell.Value, 3) = "..." Then
cell.Value = Right(cell.Value, Len(cell.Value) - 3)
End If
If Left(cell.Value, 1) = Chr(133) Then
cell.Value = Right(cell.Value, Len(cell.Value) - 1)
End If
Next
End Sub
I think you can use Characters(1,3).Insert("") to change the text
Sub Test()
Dim c As Range
Selection.Value = Application.Trim(Selection)
For Each c In Selection
If c.Characters(1,3).Text = "..." Then c.Characters(1,3).Insert("")
Next
End Sub

Adding a space between two words once

I completed code to remove any data in front of a string, add some text (with a space) to the front and store it back in the cell.
However, every time I run the macro (to check if changes that I've made are working for example), a new space is added in between the words.
The code that removes anything before the name and adds the required string. I have called a InStr function and stored the value in integer pos. Note that this is in a loop over a specific range.
If pos > 0 Then
'Removes anything before the channel name
cellValue.Offset(0, 2) = Right(cell, Len(cell) - InStr(cell, pos) - 2)
'Add "DA" to the front of the channel name
cellValue.Offset(0, 0) = "DA " & Right(cell, Len(cell) - InStr(cell, pos) - 2)
'Aligns the text to the right
cellValue.Offset(0, 2).HorizontalAlignment = xlRight
End If
An additional "DA" is not being added and I haven't made any other functions to add spaces anywhere. The extra space is not added if adding "DA " is changed to "DA".
I'd prefer not to add another function/sub/something somewhere to search and remove any extra spaces.
What the string is AND what is in front of the string is unknown. It could be numbers, characters, spaces or exactly what I want it to be. For example, it could be "Q-Quincey", "BA Bob", "DA White" etc. I thought that searching through the cell for the string I want (Quincey, Bob, White) and altering the cell as needed would be the best way.
Solution that you all helped me come up with:
If pos > 0 Then
modString = Right(cell, Len(cell) - InStr(cell, pos) - 2)
'Removes anything before the channel name and places it in the last column
cellValue.Offset(0, 2) = modString
'Aligns the last column text to the right
cellValue.Offset(0, 2).HorizontalAlignment = xlRight
cellValue.Offset(0, 2).Font.Size = 8
'Add "DA" to the front of the channel name in the rightmost column
If StartsWith(cell, "DA ") = True Then
cellValue.Replace cell, "DA" & modString
Else
cellValue.Replace cell, "DA " & modString
End If
End If
Maybe this is something you can work with:
Sample data:
Sample code:
Sub Test()
With Sheet1.Range("A1:A4")
.Replace "*quincey", "AD Quincey"
End With
End Sub
Result:
In your examples, it seems you want to replace the first "word" in the string with something else. If that is always the case, the following function, which makes use of Regular Expressions, can do that:
Option Explicit
Function replaceStart(str As String, replWith As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = "^\S+\W(?=\w)"
replaceStart = .Replace(str, replWith)
End With
End Function
Sub test()
Debug.Print replaceStart("Q-Quincy", "DA ")
Debug.Print replaceStart("BA Bob", "DA ")
Debug.Print replaceStart("DA White", "DA ")
End Sub
The debug.print will -->
DA Quincy
DA Bob
DA White
The regular expression matches everything up to but not including the first "word" character that follows a non-word character. This should be the second word in the string.
A "word" character is anything in the set of [A-Za-z0-9_]
Seems to work on the examples you present.
If you wanted to go about it through a loop you should remove some redundancies in your code. For instance, refering to cell.offset(0,0) doesn't make sense.
I would set the target cells to a range and simply edit that cell with out placing the unwanted strings in another cell.
**EDIT:
I'd try something like this.**
nameiwant = "Quincy"
Set cell = Range("A1")
If InStr(cell, nameiwant) > 0 And Left(cell, 3) <> "DA " Then
cell.Value = "DA " & nameiwant
End If

How to remove Carriage Returns (Line Breaks), but keep original font formatting (color, size, ect)?

In my cells have fonts with multiple colors and line breaks. I want to remove all the line breaks from the cells, while keeping the original font colors.
My Cells:
I've tried CTRL+H and using CTRL+J and replace all, but then all words in the cell go to one color.
I also tried using
=CLEAN(H4)
and
=SUBSTITUTE(SUBSTITUTE(H4,CHAR(13),""),CHAR(10),"")
Both options create a new column, but neither with original font color
I tried used VBA:
Sub RemoveCarriageReturns()
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each MyRange In ActiveSheet.UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), "")
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it also changed all words within a cell to one color.
Here's another VBA code I tried (recommend in comments by Foxfire And Burns And Burns):
Sub RemoveCarriageReturns()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim MyText() As String
Dim rng As Range
Dim zz As Long
Dim xx As Long
For zz = Range("H" & Rows.Count).End(xlUp).Row To 1 Step -1
Set rng = Range("H" & zz)
ReDim MyText(1 To Len(Replace(Replace(rng.Value, Chr(13), ""), Chr(10),
"")), 1 To 2) As String
xx = 1
For i = 1 To Len(rng.Value) Step 1
If Asc(Mid(rng.Value, i, 1)) <> 13 And Asc(Mid(rng.Value, i, 1)) <> 10
Then
MyText(xx, 1) = Mid(rng.Value, i, 1) 'we save text
MyText(xx, 2) = rng.Characters(i, 1).Font.Color 'we save color
xx = xx + 1
End If
Next i
For i = 1 To (xx - 1) Step 1
rng.Characters(i).Text = MyText(i, 1)
rng.Characters(i).Font.Color = MyText(i, 2)
Next i
Next zz
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
On the line ReDim MyText(1 I get Run-time error '9': Subscript out of range. From my very limited understanding of code, I tried to access a nonexistent element in an array. I'm trying to debug, but I don't quite understand how the the line works. Sorry, I wish I had a better understanding.
Welcome to SO.
Easy way would be like this one (Actually, you can even record a macro and adapt the code to your needs)
I have some text with colors and different fonts in Column A.
In column B I've used formula =SUBSTITUTE(A1;CHAR(10);"")
Then, you can select all cells in column B, and paste them onto Column A but paste as values!
Now you got original text with no linebreaks, and keeping original font and colors.
Simple VBA version of this:
Dim i As Long
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
Range("A" & i).Value = Replace(Replace(Range("A" & i).Value, Chr(10), ""), Chr(13), "")
Next i
The code will check every cell in column A, starting at last non empty one, and will remove line breaks, but keeping fonts and colors.
UPDATE: Looks like OP's problem is that in a cell can be some chars in one color and other chars in a different color, and needs to replicate same format, but excluding linebreaks, so the only solution is VBA.
I did some test with junk. As you can see in the image below, I got some texts with different colors in same cell, and 2 of them got linebreaks:
The code will check every single char in the text, excluding linebreaks. It will create an array bidimensional. First dimension will save the char, and second one will save the color number.
Later on, it will replace the original value in cell with the new one, keeping colors and text, but excluding linebreaks.
Dim i As Long
Dim MyText() As String
Dim rng As Range
Dim zz As Long
Dim xx As Long
For zz = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
Set rng = Range("A" & zz)
ReDim MyText(1 To Len(Replace(Replace(rng.Value, Chr(13), ""), Chr(10), "")), 1 To 2) As String
xx = 1
For i = 1 To Len(rng.Value) Step 1
If Asc(Mid(rng.Value, i, 1)) <> 13 And Asc(Mid(rng.Value, i, 1)) <> 10 Then
MyText(xx, 1) = Mid(rng.Value, i, 1) 'we save text
MyText(xx, 2) = rng.Characters(i, 1).Font.Color 'we save color
xx = xx + 1
End If
Next i
For i = 1 To (xx - 1) Step 1
rng.Characters(i).Text = MyText(i, 1)
rng.Characters(i).Font.Color = MyText(i, 2)
Next i
Next zz
Erase MyText
After executing code, I get this in column A:
No linebreaks, but colors and text is the same than original.
This code will keep only the color. If you need to save font name, size, bold or not, and so on, you will need to increase the dimensions of the string array, and save in each dimension what you need.
Hope now you can adapt this to your needs.

Resources