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?
Related
using VBA on excel to remove duplicates strings (whole words) from a cell, but keep the last instance of the duplicate.
Example
hello hi world hello => hi world hello
this is hello my hello world => this is my hello world
Iam originally a python developer so excuse my lack of syntax in VBA, I have edited a piece of code found online with the following logic:
'''
Function RemoveDupeWordsEnd(text As String, Optional delimiter As String = " ") As String
Dim dictionary As Object
Dim x, part, endword
Set dictionary = CreateObject("Scripting.Dictionary")
dictionary.CompareMode = vbTextCompare
For Each x In Split(text, delimiter)
part = Trim(x)
If part <> "" And Not dictionary.exists(part) Then
dictionary.Add part, Nothing
End If
'' COMMENT
'' if the word exists in dictionary remove previous instance and add the latest instance
If part <> "" And dictionary.exists(part) Then
dictionary.Del part, Nothing
endword = part
dictionary.Add endword, Nothing
End If
Next
If dictionary.Count > 0 Then
RemoveDupeWordsEnd = Join(dictionary.keys, delimiter)
Else
RemoveDupeWordsEnd = ""
End If
Set dictionary = Nothing
End Function
'''
Thanks all help and guidance would be very much appreciated
Keep the Last Occurrence of Matching Substrings
Option Explicit
Function RemoveDupeWordsEnd( _
ByVal DupeString As String, _
Optional ByVal Delimiter As String = " ") _
As String
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Item As Variant
Dim Word As String
For Each Item In Split(DupeString, Delimiter)
Word = Trim(Item)
If Len(Word) > 0 Then
If dict.Exists(Word) Then
dict.Remove Word
End If
dict(Word) = Empty ' the same as 'dict.Add Word, Empty'
End If
Next Item
If dict.Count > 0 Then RemoveDupeWordsEnd = Join(dict.Keys, Delimiter)
End Function
Use VBA's replace in a while loop that terminates when the occurrences of the string drop below 2. Replace takes an optional argument for the number of matches to replace.
Function keepLast(raw As String, r As String) As String
While (Len(raw) - Len(Replace(raw, r, ""))) / Len(r) > 1
raw = Replace(raw, r, "", , 1)
Wend
keepLast = Trim(Replace(raw, " ", " "))
End Function
I use Trim and Replace any double spaces with a single space to avoid extraneous white space that is left by the removal of the target string. You could avoid the loop by just counting the number of occurrences and passing that minus 1 straight to replace:
Function keepLast(raw As String, r As String) As String
keepLast = raw
Dim cnt As Integer
cnt = (Len(raw) - Len(Replace(raw, r, ""))) / Len(r)
If cnt < 2 Then Exit Function
raw = Replace(raw, r, "", , cnt - 1)
keepLast = Trim(Replace(raw, " ", " "))
End Function
Bear in mind that this method is very susceptible to partial matches. If your raw string was "hello that Othello is a good play hello there", then you'll end up with "that O is a good play hello there", which I don't think is exactly what you want. You might use regex to address this, if it's necessary:
Function keepLast(raw As String, r As String) As String
Dim parser As Object
Set parser = CreateObject("vbscript.regexp")
parser.Global = True
parser.Pattern = "\b" & r & "\b"
While parser.Execute(raw).Count > 1
raw = parser.Replace(raw, "")
Wend
keepLast = Trim(Replace(raw, " ", " "))
End Function
The regexp object has a property to ignore case, if you need to handle "hello" and "Hello". You would set that like this:
parser.ignoreCase = true
Late to the party, but try:
Function RemoveDups(inp As String) As String
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "(?:^| )(\S+)(?= |$)(?=.* \1(?: |$))"
RemoveDups = Application.Trim(.Replace(inp, ""))
End With
End Function
Unfortunately VBA does not support word-boundaries which would make for a much easier pattern. The idea however is to match 1+ non-whitespace characters from and upto a space/start-line/end-line and use this match with a backreference to check the word is repeated again.
Formula in B1:
=RemoveDups(A1)
Note: This is currently case-sensitive. So use the appropriate regex object properties and add: RegExp.IgnoreCase = False in case you want to use case-insensitive matching.
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
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
This site has been a veritable treasure chest of answers and ideas to many of my vba problems in the past, but i have not been able to find any concerning what i am sure is for many, if not most, here in this forum a simple task. I have to deal with a lot of xml report files that all have a header string and my problem is how to parse the string for the nuggest i require for my macro.
This is a sample string:
<Function IDREF="TST_RxRccsMatrix_Rx64" Start="2011-04-07T14:21:35.593000+02:00" Status="Success" Tags="SystemSerialNumber:41009" End="2011-04-07T14:29:16.625000+02:00">
I need to extract
- the report type: TST_RxRccsMatrix (length of this string is not constant)
- the start date-time stamp: 2011-04-07T14:21:35.593000+02:00 (length is constant)
- the serial number: 41009 (length is constant)
I have tried methods using Split and InStr and Find but none produce the desired results for all three extractions.
I truely appreciate any help on this!
The old fashion way is to use instr to find beginning. Then use instr to find ending. Then use mid to suck it out.
Begin = instr(1,xmlstring,"IDREF=") + Len("IDREF")
'look for first space after IDREF= in string
End = instr(Begin, xmlstring, " ")
Report = mid(xmlstring, begin, end - begin)
I didn't test it.
But I's split on space, then go through the array splitting on =. That will give you an array of 2 element arrays with value name in (0) and value in (1).
But xml has it's own query language and libraries to access stuff.
This is some code splitting a command line and then splitting 320x200 into 300 and 200.
CmdLine = Command()
A = Split(CmdLine, Chr(32), 2, 1)
B = Split(A(0), "x", 2, 1)
xmlstring = "<Function IDREF=""TST_RxRccsMatrix_Rx64"" Start=""2011-04-07T14:21:35.593000+02:00"" Status=""Success"" Tags=""SystemSerialNumber:41009"" End=""2011-04-07T14:29:16.625000+02:00"">"
Set regEx = New RegExp
regEx.Pattern = "IDREF=""([a-z0-9_]+)"""
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(xmlstring)
If Matches.count <> 1 then msgbox "no match or too many"
For Each Match in Matches
Msgbox match.submatches(0)
Next
I answered your qustions. The other person deleted two easier ways of doing it.
Ask Oded to put back my explanation of this code. And to restore the MS tutorial on how to do it with XML DOM objects. I showed FOUR ways.
After some polishing:
Private Sub GetFileInfo()
Dim fso As New FileSystemObject, strText As Variant, i As Integer
Dim X(0 To 2) As String, Y(0 To 2) As String, B, E As Variant
'get header string from xml file
'FName (file name) was ascertained by a previous sub and is made public
Set strText = fso.OpenTextFile(FName, ForReading, False)
'header string is in second (i = 2) line of file
For i = 1 To 2: [A1] = strText.ReadLine: Next: strText.Close: Set fso = Nothing
'User Oded's search and extract routine
X(0) = "IDREF=": X(1) = "Start=": X(2) = "Tags="
For i = LBound(X(), 1) To UBound(X(), 1)
B = InStr(1, [A1], X(i)) + Len(X(i)) + 1 ' + 1 includes trailing " character
E = InStr(B, [A1], " ") - 1 ' - 1 includes leading " character
'required if a search string in X() is at the end of the header which ends with a ">"
If (InStr(B, [A1], " ") - 1) < 0 Then E = InStr(B, [A1], ">")
Y(i) = Mid([A1], B, E - B)
Next
[D1] = "Test = " & Y(0)
[D2] = "Tested on : " & Left(Y(1), 10) & " at " & Mid(Y(1), 12, 8)
[D2] = [D2] & " - " & Y(2)
End Sub
Why trim is not working in VBA?
for i = 3 to 2000
activesheet.cells(i,"C").value = trim(Activesheet.cells(i,"C").value)
next i
It is unable to remove the spaces in between the text.
hiii how ' even after trying trim the o/p is still these
hiii how
I need to remove the extra spaces so I found Trim to do it but it is not working while ltrim and rtrim are.
The VBA Trim function is different than Excel's. Use Excel's Application.WorksheetFunction.Trim function instead.
Excel Trim will remove all spaces except a single space between words. VBA Trim will remove leading and trailing spaces.
Thank MS for using the same keyword for different functions.
Trim removes extra spaces at start and end, not in the middle of a string.
Function CleanSpace(ByVal strIn As String) As String
strIn = Trim(strIn)
' // Replace all double space pairings with single spaces
Do While InStr(strIn, " ")
strIn = Replace(strIn, " ", " ")
Loop
CleanSpace = strIn
End Function
From here.
PS. It's not the most efficient way to remove spaces. I wouldn't use on many, very long strings or in a tight loop. It might be suitable for your situation.
I know this question is old but I just found it and thought I'd add what I use to remove multiple spaces in VBA....
cleanString = Replace(Replace(Replace(Trim(cleanString), _
" ", " |"), "| ", ""), " |", " ") 'reduce multiple spaces chr(32) to one
When you call Trim() VBA is actually calling Strings.Trim(). This function will only remove leading and trailing spaces. To remove excessive spaces within a string, use
Application.Trim()
Are all your other functions leaving whitespace behind?
Get CleanUltra!
CleanUltra removes all whitespace and non-printable characters including whitespace left behind by other functions!
I hope you find this useful. Any improvements are welcome!
Function CleanUltra( _
ByVal stringToClean As String, _
Optional ByVal removeSpacesBetweenWords As Boolean = False) _
As String
' Removes non-printable characters and whitespace from a string
' Remove the 1 character vbNullChar. This must be done first
' if the string contains vbNullChar
stringToClean = Replace(stringToClean, vbNullChar, vbNullString)
' Remove non-printable characters.
stringToClean = Application.Clean(stringToClean)
' Remove all spaces except single spaces between words
stringToClean = Application.Trim(stringToClean)
If removeSpacesBetweenWords = True Then _
stringToClean = Replace(stringToClean, " ", vbNullString)
CleanUltra = stringToClean
End Function
Here's an example of it's usage:
Sub Example()
Dim myVar As String
myVar = " abc d e "
MsgBox CleanUltra(myVar)
End Sub
Here's a test I ran to verify that the function actually removed all whitespace. vbNullChar was particularly devious. I had to set the function to remove it first, before the CLEAN and TRIM functions were used to stop them from removing all characters after the vbNullChar.
Sub Example()
Dim whitespaceSample As String
Dim myVar As String
' Examples of various types of whitespace
' (vbNullChar is particularly devious!)
whitespaceSample = vbNewLine & _
vbCrLf & _
vbVerticalTab & _
vbFormFeed & _
vbCr & _
vbLf & _
vbNullChar
myVar = " 1234" & _
whitespaceSample & _
" 56 " & _
"789 "
Debug.Print "ORIGINAL"
Debug.Print myVar
Debug.Print "Character Count: " & Len(myVar)
Debug.Print
Debug.Print "CLEANED, Option FALSE"
Debug.Print CleanUltra(myVar)
Debug.Print CleanUltra(myVar, False)
' Both of these perform the same action. If the optional parameter to
' remove spaces between words is left blank it defaults to FALSE.
' Whitespace is removed but spaces between words are preserved.
Debug.Print "Character Count: " & Len(CleanUltra(myVar))
Debug.Print
Debug.Print "CLEANED, Option TRUE"
Debug.Print CleanUltra(myVar, True)
' Optional parameter to remove spaces between words is set to TRUE.
' Whitespace and all spaces between words are removed.
Debug.Print "Character Count: " & Len(CleanUltra(myVar, True))
End Sub
My related issue was that the last character was a chr(160) - a non-breaking space. So trim(replace(Str,chr(160),"")) was the solution.
I know this question is old but I just want to share my solution on how to deal and fix with this issue.
Maybe you might wondering why sometimes TRIM function isn't working, remember that it will only remove spaces and spaces are equivalent to ASCII 32. So if these ASCII 13 or ASCII 10 exists in the Beginning or end of your string value then TRIM function will not work on it.
Function checkASCIItoBeRemoved(myVal) As String
Dim temp As String
temp = Replace(Trim(myVal), Chr(10), Empty)
temp = Replace(temp, Chr(13), Empty)
checkASCIItoBeRemoved = temp
End Function
With this code it works for me, by the way if this might not work on your side then try to check the ASCII of you string value because it might have another invisible special char that might not covered on my code to replace on it, kindly add on it to work.
Please see reference for some invisible special char.
I know this is quite old but thought I'd add in something else rather than all these replace options.
Using trim (or trim$) in VBA will remove the leading and trailing spaces, which as mentioned is different from =TRIM in Excel.
If you need to remove spaces (as mentioned below not necessarily all whitespace) from inside a string simply use WorksheetFunction.Trim.
Sometimes what looks to be a space is not a space but a character that cannot be displayed.
Use the ASC function to get the integer value of the character. Then use the following code:
Function CleanSpace(ByVal StrIn As String) As String
StrIn = Trim(StrIn)
' Searches string from end and trims off excess ascii characters
Dim StrLength As Integer
Dim SingleChar As Integer
Dim StrPosition As Integer
SingleChar = 1
StrLength = Len(StrIn)
StrPosition = StrLength - 1
Do Until Asc(Mid(StrIn, StrPosition, SingleChar)) <> 0
StrPosition = StrPosition - 1
Loop
StrIn = Mid(StrIn, 1, StrPosition)
End Function
If You are familiar with collections, i once wrote a quick code that process the whole sheet even if it is huge and remove all double spaces, lead and trail spaces and invisible characters from all cells. Just take care it will remove the format of your text, i also did not do much testing and it's exhaustive but it worked for my short task and worked fast.
This is an Auxiliary function that loads the sheet into a collection
Function LoadInCol() As Collection
Dim currColl As Collection
Dim currColl2 As Collection
Set currColl = New Collection
Set currColl2 = New Collection
With ActiveSheet.UsedRange
LastCol = .Columns(.Columns.Count).Column
lastrow = .Rows(.Rows.Count).Row
End With
For i = 1 To lastrow
For j = 1 To LastCol
currColl.Add Cells(i, j).Value
Next
currColl2.Add currColl
Set currColl = New Collection
Next
Set LoadInCol = currColl2
End Function
And this is the main Sub that removes the spaces
Sub RemoveDSpaces()
'Removes double spaces from the whole sheet
Dim Col1 As Collection
Dim Col2 As Collection
Dim Col3 As Collection
Dim StrIn As String
Dim Count As Long
Set Col1 = New Collection
Set Col2 = New Collection
Set Col3 = New Collection
Set Col1 = LoadInCol()
Count = Col1.Count
i = 0
For Each Item In Col1
i = i + 1
If i >= Count + 1 Then Exit For
Set Col2 = Item
For Each Item2 In Col2
StrIn = WorksheetFunction.Clean(Trim(Item2))
Do Until InStr(1, StrIn, " ", vbBinaryCompare) = 0
StrIn = Replace(StrIn, " ", Chr(32))
Loop
Col3.Add StrIn
Next
Col1.Remove (1)
Col1.Add Col3
Set Col3 = New Collection
Next
'Store Results
Cells.ClearContents
Z = 1
m = 1
Set Col3 = New Collection
For Each Item In Col1
Set Col3 = Item
For Each Item2 In Col3
Cells(Z, m) = Item2
m = m + 1
Next
m = 1
Z = Z + 1
Next
End Sub