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
Related
I am trying to replace not each space in a single string with line break. String is taken from specific cell, and looks like:
Now, Im trying to replace each space after abbreviation to line break. The abbreviation can be any, so the best way for precaching which space I intend to replace is like: each space after number and before a letter?
The output I want to get is like:
Below is my code, but it will change every space to line break in cell.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Exitsub
If Not Intersect(Target, .Columns(6)) Is Nothing Then
Application.EnableEvents = False
Target.Value = Replace(Target, " ", Chr(10))
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
You can try
Target.Value = Replace(Target, "kg ", "kg" & Chr(10))
If you can have other abbreviations like "g" or "t", do something similar for them (maybe in a Sub), just be cautious with the order (replace first "kg", then "g")
Update: If you don't know in advance the possible abbreviations, one attempt is to use regular expressions. I'm not really good with them, but the following routine seems to do:
Function replaceAbbr(s As String) As String
Dim regex As New RegExp
regex.Global = True
regex.Pattern = "([a-z]+) "
replaceAbbr = regex.Replace(s, "$1" & Chr(10))
End Function
The below will replace every 2nd space with a carriage return. For reason unknown to me The worksheet function Replace will work as intended, but the VBA Replace doesnt
This will loop through every character in the defined area, you can change this to whatever you want.
The if statement is broken down as such
(SpaceCount Mod 2) = 0 this part is what enable it to get every 2nd character.
As a side note (SpaceCount Mod 3) = 0 will get the 3rd character and (SpaceCount Mod 2) = 1 will do the first character then every other character
Cells(1, 1).Characters(CountChr, 1).Text = " " is to make sure we are replacing a space, if the users enters something funny that looks like a space but isn't, that's on them
I believe something like this will work as intended for you
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Exitsub
Application.EnableEvents = False
For CountChr = 1 To Len(Target.Value)
If Target.Characters(CountChr, 1).Text = " " Then
Dim SpaceCount As Integer
SpaceCount = SpaceCount + 1
If (SpaceCount Mod 2) = 0 Then
Target.Value = WorksheetFunction.Replace(Target.Value, CountChr, 1, Chr(10))
End If
End If
Next CountChr
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Identify arbitrary abbreviation first
"abbreviations aren't determined ..."
Knowing the varying abbreviation which, however is the same within each string (here e.g. kg ) actually helps following the initial idea to look at the blanks first: but instead of replacing them all by vbLf or Chr(10), this approach
a) splits the string at this " " delimiter into a zero-based tmp array and immediately identifies the arbitrary abbreviation abbr as second token, i.e. tmp(1)
b) executes a negative filtering to get the numeric data and eventually
c) joins them together using the abbreviation which is known now for the given string.
So you could change your assignment to
'...
Target.Value = repl(Target) ' << calling help function repl()
Possible help function
Function repl(ByVal s As String) As String
'a) split into tokens and identify arbitrary abbreviation
Dim tmp, abbr As String
tmp = Split(s, " "): abbr = tmp(1)
'b) filter out abbreviation
tmp = Filter(tmp, abbr, Include:=False)
'c) return result string
repl = Join(tmp, " " & abbr & vbLf) & abbr
End Function
Edit // responding to FunThomas ' comment
ad a): If there might be missing spaces between number and abbreviation, the above approach could be modified as follows:
Function repl(ByVal s As String) As String
'a) split into tokens and identify arbitrary abbreviation
Dim tmp, abbr As String
tmp = Split(s, " "): abbr = tmp(1)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'b) renew splitting via found abbreviation (plus blank)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tmp = Split(s & " ", abbr & " ")
'c) return result string
repl = Join(tmp, abbr & vbLf): repl = Left(repl, Len(repl) - 1)
End Function
ad b): following OP citing e.g. "10 kg 20 kg 30,5kg 15kg 130,5 kg" (and as already remarked above) assumption is made that the abbreviation is the same for all values within one string, but can vary from item to item.
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
I'm looking for a macro (preferably a function) that would take cell contents, split it into separate words, compare them to one another and remove the shorter words.
Here's an image of what I want the output to look like (I need the words that are crossed out removed):
I tried to write a macro myself, but it doesn't work 100% properly because it's not taking the last words and sometimes removes what shouldn't be removed. Also, I have to do this on around 50k cells, so a macro takes a lot of time to run, that's why I'd prefer it to be a function. I guess I shouldn't use the replace function, but I couldn't make anything else work.
Sub clean_words_containing_eachother()
Dim sht1 As Worksheet
Dim LastRow As Long
Dim Cell As Range
Dim cell_value As String
Dim word, word2 As Variant
Set sht1 = ActiveSheet
col = InputBox("Which column do you want to clear?")
LastRow = sht1.Cells(sht1.Rows.Count, col).End(xlUp).Row
Let to_clean = col & "2:" & col & LastRow
For i = 2 To LastRow
For Each Cell In sht1.Range(to_clean)
cell_value = Cell.Value
cell_split = Split(cell_value, " ")
For Each word In cell_split
For Each word2 In cell_split
If word <> word2 Then
If InStr(word2, word) > 0 Then
If Len(word) < Len(word2) Then
word = word & " "
Cell = Replace(Cell, word, " ")
ElseIf Len(word) > Len(word2) Then
word2 = word2 & " "
Cell = Replace(Cell, word2, " ")
End If
End If
End If
Next word2
Next word
Next Cell
Next i
End Sub
Assuming that the retention of the third word in your first example is an error, since books is contained later on in notebooks:
5003886 book books bound case casebound not notebook notebooks office oxford sign signature
and also assuming that you would want to remove duplicate identical words, even if they are not contained subsequently in another word, then we can use a Regular Expression.
The regex will:
Capture each word
look-ahead to see if that word exists later on in the string
if it does, remove it
Since VBA regexes cannot also look-behind, we work-around this limitation by running the regex a second time on the reversed string.
Then remove the extra spaces and we are done.
Option Explicit
Function cleanWords(S As String) As String
Dim RE As Object, MC As Object, M As Object
Dim sTemp As String
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.Pattern = "\b(\w+)\b(?=.*\1)"
.ignorecase = True
'replace looking forward
sTemp = .Replace(S, "")
' check in reverse
sTemp = .Replace(StrReverse(sTemp), "")
'return to normal
sTemp = StrReverse(sTemp)
'Remove extraneous spaces
cleanWords = WorksheetFunction.Trim(sTemp)
End With
End Function
Limitations
punctuation will not be removed
a "word" is defined as containing only the characters in the class [_A-Za-z0-9] (letters, digits and the underscore).
if any words might be hyphenated, or contain other non-word characters
in the above, they will be treated as two separate words
if you want it treated as a single word, then we might need to change the regex
General steps:
Write cell to array (already working)
for each element (x), go through each element (y) (already working)
if x is in y AND y is longer that x THEN set x to ""
concat array back into string
write string to cell
String/array manipulations are much faster than operations on cells, so this will give you some increase in performance (depending on the amount of words you need to replace for each cell).
The "last word problem" might be that you dont have a space after the last word within your cells, since you only replace word + " " with " ".
I am trying to remove all letters from a cell and leave the numbers remaining.
I have found bits of code and other questions on here but none are making much sense to me.
I have in cell E23 "as12df34" and want the value of Cell E23 to read "12 34"
Can anyone help with this query please?
You could use a regular expression:
Sub UsageExample()
Dim cl
' iterate each cell
For Each cl in Range("Sheet1!A1:A100")
' replace each non digit sequence by a space
cl.Value = ReplaceRe(cl.Value, "\D+", " ")
Next
End Sub
Public Function ReplaceRe(text As String, pattern As String, replacement) As String
Static re As Object
If re Is Nothing Then
Set re = CreateObject("VBScript.RegExp")
re.Global = True
End If
re.pattern = pattern
ReplaceRe = re.Replace(text, replacement)
End Function
Here's a UDF if you want to do something like that. Making "Spaces" True or False will allow for you to have a single space where non-numeric characters used to be.
Sub Test()
Debug.Print Nums("as12df34", True)
End Sub
Function Nums(What As String, Spaces As Boolean) As String
Dim i As Long
For i = 1 To Len(What)
If IsNumeric(Mid(What, i, 1)) = True Then Nums = Nums & Mid(What, i, 1)
If IsNumeric(Mid(What, i, 1)) = False Then Nums = Nums & " "
Next i
Nums = Trim(Nums)
If Spaces = True Then
Do Until InStr(Nums, " ") = 0
Nums = Replace(Nums, " ", " ")
Loop
Else
Do Until InStr(Nums, " ") = 0
Nums = Replace(Nums, " ", "")
Loop
End If
End Function
I know this may have been answered, but I wanted to let others that may come across this question to see another possibility. I came up with an obvious solution to eliminate all the letters to be replaced with nothing to only leave numbers in the cell. You can just replace the "" for a " " to leave the space that the letters left behind.
It's a huge clutter, but I use it and it works as intended just drag the function to the next cell. No typing required. In my situation, I had a word like "platinum ingot, 3" and it will remove all the letters, comma, and spaces and leaves 3 which can be used to calculate stuff with. I use this to hold 2 values in 1 cell when 1 of the value is never going to also contain numbers.
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE( SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE( SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE( SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE( SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE( SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE( F5,"A",""),"B",""),"C",""),"D",""),"E",""),"F",""),"G",""),"H",""),"I",""),"J",""),"K",""),"L",""),"M",""),"N",""),"O",""),"P",""),"Q",""),"R",""),"S",""),"T",""),"U",""),"V",""),"W",""),"X",""),"Y",""),"Z",""),"a",""),"b",""),"c",""),"d",""),"e",""),"f",""),"g",""),"h",""),"i",""),"j",""),"k",""),"l",""),"m",""),"n",""),"o",""),"p",""),"q",""),"r",""),"s",""),"t","") ,"u",""),"v","") ,"w",""),"x",""),"y",""),"z",""),",","")," ","")
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.