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
Related
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.
I am required to extract passages of text from the contents of Excel cells in which the originator has essentially done a manual Track Changes using Strikethrough font. The passages are identifiable with certain character patterns, but I have to ignore Strikethrough characters to see them. The Strikethrough characters do not appear in regular locations within each cell, so are essentially randomly dispersed with normal font text.
I have achieved my goal using VBA for Excel, but the solution is extremely (and impracticably) slow. Having searched this site and the wider web for answers, it seems the use of the Characters object is to blame.
So my question is: has anyone found a way of parsing such text that does not involve the Characters object?
The sub I wrote to do the parsing is too long to post here, but following is some test code which uses the Characters object in a similar way. This takes 60 s to parse a cell with 3000 characters in it. At that speed, it would take 50 hours to process the entire spreadsheet I've been given.
Private Sub FindLineBreakChars(TargetCell As Excel.Range)
Dim n As Integer
Dim ch As String
Dim st As Boolean
If TargetCell.Cells.Count <> 1 Then
Call MsgBox("Error: more or less than one cell in range specified.")
Else
If IsEmpty(TargetCell.Value) Then
Call MsgBox("Error: target cell is empty.")
Else
If Len(TargetCell.Value) = 0 Then
Call MsgBox("Error: target cell contains an empty string.")
Else
'Parse the characters in the cell one by one.
For n = 1 To TargetCell.Characters.Count
ch = TargetCell.Characters(n, 1).Text
st = TargetCell.Characters(n, 1).Font.Strikethrough
If ch = vbCr Then
Debug.Print "#" & n & ": Carriage Return (vbCr)" & ", strikethrough = " & st & vbCrLf
ElseIf ch = vbLf Then
Debug.Print "#" & n & ": Line Feed (vbLf)" & ", strikethrough = " & st & vbCrLf
End If
Next n
End If
End If
End If
End Sub
You're right, the access to Characters is very slow, so your goal should be to reduce it's usage as much as possible.
I don't understand your requirement details, but the following code should get you an idea how you could speed up the code. It reads the content of a cell only once, split the text into separate lines, calculates the position of the single linefeed characters and look at that position for the formatting. As far as I know there is no way to access the formatting all at once, but now the access to the characters-object is reduced to one per line:
With TargetCell
Dim lines() As String, lineNo As Integer, textLen As Long
lines = Split(.Value2, vbLf)
textLen = Len(lines(0)) + 1
For lineNo = 1 To UBound(lines)
Dim st
st = .Characters(textLen, 1).Font.Strikethrough
Debug.Print "#" & textLen & ": LineFeed (vbLf) strikethrough = " & st
textLen = textLen + Len(lines(lineNo)) + 1
Next lineNo
End With
To my knowledge, Excel stores Linebreaks in a cell using just the LineFeed character, so the code is checking only that.
This might meet your performance needs: it calls a function which parses the XML representation of the cell content, removes the struck-out sections, and returns the remaining text.
It will be much faster than looping over Characters
Sub Tester()
Debug.Print NoStrikeThrough(Range("A1"))
End Sub
'Needs a reference to Microsoft XML, v6.0
' in your VBA Project references
Function NoStrikeThrough(c As Range) '
Dim doc As New MSXML2.DOMDocument60, rv As String
Dim x As MSXML2.IXMLDOMNode, s As MSXML2.IXMLDOMNode
'need to add some namespaces
doc.SetProperty "SelectionNamespaces", _
"xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
"xmlns:ht='http://www.w3.org/TR/REC-html40'"
doc.LoadXML c.Value(11) 'cell data as XML
Set x = doc.SelectSingleNode("//ss:Data")'<< cell content
Set s = x.SelectSingleNode("//ht:S") '<< strikethrough
Do While Not s Is Nothing
Debug.Print "Struck:", s.Text
x.RemoveChild s '<< remove struck section
Set s = x.SelectSingleNode("//ht:S")
Loop
NoStrikeThrough = doc.Text
End Function
EDIT: here's another way to go at it, by breaking up the text into "blocks" and checking each block to see if it has any strikethrough. How much faster this is than going character-by-character may depend on block size and the distribution of struck-out text in each cell.
Function NoStrikeThrough2(c As Range)
Const BLOCK As Long = 50
Dim L As Long, i As Long, n As Long, pos As Long, x As Long
Dim rv As String, s As String, v
L = Len(c.Value)
n = Application.Ceiling(L / BLOCK, 1) 'how many blocks to check
pos = 1 'block start position
For i = 1 To n
v = c.Characters(pos, BLOCK).Font.Strikethrough
If IsNull(v) Then
'if strikethough is "mixed" in this block - parse out
' character-by-character
s = ""
For x = pos To pos + BLOCK
If Not c.Characters(x, 1).Font.Strikethrough Then
s = s & c.Characters(x, 1).Text
End If
Next x
rv = rv & s
ElseIf v = False Then
'no strikethrough - take the whole block
rv = rv & c.Characters(pos, BLOCK).Text
End If
pos = pos + BLOCK 'next block position.
Next i
NoStrikeThrough2 = rv
End Function
EDIT2: if you need to make sure all newline characters are not struck out before processing the cell -
Sub ClearParaStrikes(c As Range)
Dim pos As Long
pos = InStr(pos + 1, c.Value, vbLf)
Do While pos > 0
Debug.Print "vbLf at " & pos
c.Characters(pos, 1).Font.Strikethrough = False
pos = InStr(pos + 1, c.Value, vbLf)
Loop
End Sub
So currently in column B, there are cells that have no spaces before them but there are also cells that do.
For example: cell B1 would just be "Market:" but then cell B4, B5,B6,B10, B14, etc would have "_____Total:" ( __ meaning blank space)
What would I have to write to delete the 5 spaces before "Total:"?
I currently have:
mos = Range("B:B")
For Each x In mos
xv = x.Value
If Left(xv, 1) = "" Then xv = Right(xv, Len(xv) - 1)
Next xv
which gives me an error.
Please let me know what I should do.
Thanks!
Use Trim$ function. Trim function removes excess trailing and leading white space. Trim$ is a typed function and is faster.
Using Intersect, as below, means only processing the necessary number of rows and not the entire column B.
Be explicit. Put Option Explicit at the top of your code to force variable declaration and declare your variables. And fully qualify which sheet you are working with.
As noted in another answer, there are variants such as LTrim$ just to remove from left (Start of string) and RTrim$, just to remove from right (end of string).
Code:
Option Explicit
Public Sub test()
Dim mos As Range
Dim x As Range
With ActiveSheet 'change to appropriate worksheetname
Set mos = .Range("B:B")
For Each x In Intersect(mos, .UsedRange)
x = Trim$(x)
Next x
End With
End Sub
Bonus:
There are a lot of existing functions written to "clean" strings removing all "extra" white space characters i.e. leaving only single internal white spaces.
Here is one by Henry Habermacher
Public Function removeObsoleteWhiteSpace _
(FromString As Variant) As Variant
If IsNull(FromString) Then 'handle Null values
removeObsoleteWhiteSpace = Null
Exit Function
End If
Dim strTemp As String
strTemp = Replace(FromString, vbCr, " ")
strTemp = Replace(strTemp, vbLf, " ")
strTemp = Replace(strTemp, vbTab, " ")
strTemp = Replace(strTemp, vbVerticalTab, " ")
strTemp = Replace(strTemp, vbBack, " ")
strTemp = Replace(strTemp, vbNullChar, " ")
While InStr(strTemp, " ") > 0
strTemp = Replace(strTemp, " ", " ")
Wend
strTemp = Trim(strTemp)
removeObsoleteWhiteSpace = strTemp
End Function
Example call:
Public Sub testing()
Debug.Print removeObsoleteWhiteSpace(" my string with a few spaces ")
End Sub
To avoid looping you can use:
Dim myAddress As String
myAddress = "B1:B" & Cells(Rows.Count, 2).End(xlUp).Row
Range(myAddress) = Evaluate("IF(" & myAddress & "="""","""",TRIM(" & myAddress & "))")
which can be also written as:
With Range("B1", Cells(Rows.Count, 2).End(xlUp))
.Value = Evaluate("IF(" & .Address & "="""","""",TRIM(" & .Address & "))")
End With
or Replace() method:
Range("B1", Cells(Rows.Count, 2).End(xlUp)).Replace what:=" ", replacement:="", lookat:=xlPart
of course all above solutions assume that you only have extra spaces at the beginning of each cell content, or they will trim (first two solutions) or eliminate (3rd solution) other spaces also
if you actually have the need to eliminate the leading spaces (the ones preceding the first not blank character) leaving all other ones in place, then you have to loop and use LTrim() VBA function:
Dim cell As Range
For Each cell In Range("B1", Cells(Rows.Count, 2).End(xlUp))
cell.Value = LTrim(cell.Value)
Next
Sorry, didn't realize your loop was only to remove spaces.
This is how I trim my spaces:
Sub trim()
Dim mos As Range
Set mos = Range("B:B")
mos.Value = Application.trim(mos)
End Sub
I'm trying to prepare a spreadsheet for a report in excel vba. Unforturnately there are some wierd characters here that need to be replaced. Easy enough, except for this chracter:
¦
I can't seem to be able to paste that character into the editor into a string replace function. When I try, the output is _. I then thought to refer to it by it's Chr code. A quick look up said it was Chr(166). http://www.gtwiki.org/mwiki/?title=VB_Chr_Values
Replace(s, "â€" + Chr(166), "...")
But this is not that character at all (at least on Mac excel). I tried:
For i = 1 To 255
Debug.Print Chr(i)
Next i
And I didn't see this character anywhere. Does anyone know how I can reference this character in vba code in order to replace it?
Not sure if regexp is available for vba-mac, but you could simplify your existing code greatly as below.
Uses a sample Strin
Dim strIn As String
strIn = "1â€1â€x123"
Do While InStr(strIn, "â€") > 0
Mid$(strIn, InStr(strIn, "â€"), 3) = "..."
Loop
Click on a cell containing your miscreant character and run this small macro:
Sub WhatIsIt()
Dim s As String, mesage As String
Dim L As Long
s = ActiveCell.Text
L = Len(s)
For i = 1 To L
ch = Mid(s, i, 1)
cd = Asc(ch)
mesage = mesage & ch & " " & cd & vbCrLf
Next i
MsgBox mesage
End Sub
It should reveal the characters in the cell and their codes.
It's dirty, but here's the workaround that I used to solve this problem. I knew that my issue character was always after "â€", so the idea was to replace the character that came after those 2. I don't really know how to replace a character at a position in a string, so my idea was to covert the string to an array of characters and replace the array at those specific indexes. Here's what it looks like:
Do While InStr(s, "â€") > 1
num2 = InStr(s, "â€")
arr = stringToArray(s)
arr(num2 - 1) = "<~>"
arr(num2) = "<~>"
arr(num2 + 1) = "<~>"
s = Replace(arrayToString(arr), "<~><~><~>", "...")
Loop
...
Function stringToArray(ByVal my_string As String) As Variant
Dim buff() As String
ReDim buff(Len(my_string) - 1)
For i = 1 To Len(my_string)
buff(i - 1) = Mid$(my_string, i, 1)
Next
stringToArray = buff
End Function
Function arrayToString(ByVal arr As Variant) As String
Dim s As String
For Each j In arr
s = s & j
Next j
arrayToString = s
End Function
In practice, what I replaced those indexes with is something that had to be unique but recognizable. Then i can replace my unique characters with whatever I want. There are sure to be edge cases, but for now it gets the job done. stringToArray function pulled from: Split string into array of characters?
I am trying to use a vlookup or similar function to search a worksheet, match account numbers, then return a specified value. My problem is there are duplicate account numbers and I would like the result to concatenate the results into one string.
Acct No CropType
------- ---------
0001 Grain
0001 OilSeed
0001 Hay
0002 Grain
Is in the first worksheet, on the 2nd worksheet I have the Acct No with other information and I need to get all the matching results into one column on the 2nd worksheet ie. "Grain Oilseed Hay"
Here is a function that will do it for you. It's a little different from Vlookup in that you will only give it the search column, not the whole range, then as the third parameter you will tell it how many columns to go left (negative numbers) or right (positive) in order to get your return value.
I also added the option to use a seperator, in your case you will use " ". Here is the function call for you, assuming the first row with Acct No. is A and the results is row B:
=vlookupall("0001", A:A, 1, " ")
Here is the function:
Function VLookupAll(ByVal lookup_value As String, _
ByVal lookup_column As range, _
ByVal return_value_column As Long, _
Optional seperator As String = ", ") As String
Dim i As Long
Dim result As String
For i = 1 To lookup_column.Rows.count
If Len(lookup_column(i, 1).text) <> 0 Then
If lookup_column(i, 1).text = lookup_value Then
result = result & (lookup_column(i).offset(0, return_value_column).text & seperator)
End If
End If
Next
If Len(result) <> 0 Then
result = Left(result, Len(result) - Len(seperator))
End If
VLookupAll = result
End Function
Notes:
I made ", " the default seperator for results if you don't enter one.
If there is one or more hits, I added some checking at the end to
make sure the string doesn't end with an extra seperator.
I've used A:A as the range since I don't know your range, but
obviously it's faster if you enter the actual range.
One way to do this would be to use an array formula to populate all of the matches into a hidden column and then concatenate those values into your string for display:
=IFERROR(INDEX(cropTypeValues,SMALL(IF(accLookup=accNumValues,ROW(accNumValues)-MIN(ROW(accNumValues))+1,""),ROW(A1))),"")
cropTypeValues: Named range holding the list of your crop types.
accLookup: Named range holding the account number to lookup.
accNumValues: Named range holding the list of your account
numbers.
Enter as an array formula (Ctrl+Shift+Enter) and then copy down as far as necessary.
Let me know if you need any part of the formula explaining.
I've just had a similar problem and I have looked up similar solutions for a long time, nothing really convinced me though. Either you had to write a macro, or some special function, while yet, for my needs the easiest solution is to use a pivot table in e.g. Excel.
If you create a new pivot table from your data and first add "Acct No" as row label and then add "CropType" as RowLabel you will have a very nice grouping that lists for each account all the crop types. It won't do that in a single cell though.
Here is my code which even better than an excel vlookup because you can choose to criterie colum, and for sure a separator (Carriege return too)...
Function Lookup_concat(source As String, tableau As Range, separator As String, colSRC As Integer, colDST As Integer) As String
Dim i, y As Integer
Dim result As String
If separator = "CRLF" Then
separator = Chr(10)
End If
y = tableau.Rows.Count
result = ""
For i = 1 To y
If (tableau.Cells(i, colSRC) = source) Then
If result = "" Then
result = tableau.Cells(i, colDST)
Else
result = result & separator & tableau.Cells(i, colDST)
End If
End If
Next
Lookup_concat = result
End Function
And a gift, you can make also a lookup on multiple element of the same cell (based on the same separator). Really usefull
Function Concat_Lookup(source As String, tableau As Range, separator As String, colSRC As Integer, colDST As Integer) As String
Dim i, y As Integer
Dim result As String
Dim Splitted As Variant
If separator = "CRLF" Then
separator = Chr(10)
End If
Splitted = split(source, separator)
y = tableau.Rows.Count
result = ""
For i = 1 To y
For Each word In Splitted
If (tableau.Cells(i, colSRC) = word) Then
If result = "" Then
result = tableau.Cells(i, colDST)
Else
Dim Splitted1 As Variant
Splitted1 = split(result, separator)
If IsInArray(tableau.Cells(i, colDST), Splitted1) = False Then
result = result & separator & tableau.Cells(i, colDST)
End If
End If
End If
Next
Next
Concat_Lookup = result
End Function
Previous sub needs this function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Function VLookupAll(vValue, rngAll As Range, iCol As Integer, Optional sSep As String = ", ")
Dim rCell As Range
Dim rng As Range
On Error GoTo ErrHandler
Set rng = Intersect(rngAll, rngAll.Columns(1))
For Each rCell In rng
If rCell.Value = vValue Then
VLookupAll = VLookupAll & sSep & rCell.Offset(0, iCol - 1).Value
End If
Next rCell
If VLookupAll = "" Then
VLookupAll = CVErr(xlErrNA)
Else
VLookupAll = Right(VLookupAll, Len(VLookupAll) - Len(sSep))
End If
ErrHandler:
If Err.Number <> 0 Then VLookupAll = CVErr(xlErrValue)
End Function
Use like this:
=VLookupAll(K1, A1:C25, 3)
to look up all occurrences of the value of K1 in the range A1:A25 and to return the corresponding values from column C, separated by commas.
If you want to sum values, you can use SUMIF, for example
=SUMIF(A1:A25, K1, C1:C25)
to sum the values in C1:C25 where the corresponding values in column A equal the value of K1.
ALL D BEST.