Remove white spaces in a single column - vba

I have a sheet that I need to remove the spaces from so I can compare it I am using a function I found on here and a sub that puts all the values into an array (for speed) but I cannot get it to work any idea why. I get a
ByRef argument type mismatch error
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
Sub stringRangeToClean()
Dim r As Variant
Dim i As Long
r = ActiveWorkbook.Sheets("Trent BASE DATA").UsedRange
For i = 2 To UBound(r)
r(i, 10).Value2 = RemoveWhiteSpace(r(i, 10))
Next i
End Sub
now trying this have I realised the col I is actually (I,9)
but im getting an error user defined type error on the RegExp line
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
Sub stringRangeToClean()
Dim r As Variant
Dim i As Long
Dim txt As String
r = ActiveWorkbook.Sheets("Trent BASE DATA").UsedRange
For i = 2 To UBound(r)
txt = r(i, 9)
txt = RemoveWhiteSpace(txt)
Next i
End Sub

Here you go, no regex required for simply removing spaces. Your main challenge is just defining your range which is basic VBA:
Sub tgr()
With ActiveWorkbook.Sheets("Trent BASE DATA")
.Range("J2", .Cells(.Rows.Count, "J").End(xlUp)).Replace " ", vbNullString
End With
End Sub

Try like this:
Public Function RemoveWhiteSpace(target As String) As String
Dim RegExp As Object
Set RegExp = CreateObject("VBScript.RegExp")
With RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
This way you are using a late binding for the regExp variable, thus neither you nor your users have to add any additional library.
If you want to use the early binding, you should add the Microsoft VBScript Regular Expressions 5.5" library to the ones, that VBA uses. The early binding gives you some time bonus and it provides IntelliSense.
Here the selected answer explains step-by-step how to add the library:
How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
Concerning your code - this is very simply loop, try to do it:
Sub StringRangeToClean()
Dim r As Variant
Dim myCell As Range
r = ActiveWorkbook.Sheets("Trent BASE DATA").UsedRange
For Each myCell In r
myCell = RemoveWhiteSpace(txt)
Next myCell
End Sub
This way every cell would be examined and the white spaces would be removed.

Related

Remove blank line in a string

I want to remove blank lines in a string as follows:
"First section
Second section
Third section"
I display a rolling index on every content slide so as you click through the slides, the index highlights the section you are in. I don't want to display subsections, so I tried to replace section names starting with "-" with "", but that means I have blank lines. So now I want to remove the blank lines.
I tried:
IIF statements but replacing with "" doesn't remove a blank line
Regular expressions, another link suggested the following pattern would work: #"^\s+$[\r\n]*" but the # throws up an error and it doesn't work in any case
I tried something like the below:
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Multiline = True
.Global = True
resultString = .Replace(subjectString, "\s\n", string.empty)
MsgBox resultString
End With
Another potential solution I found on stackoverflow.
Dim xArr() as string
xArr = Split(TextBox1.Value, vbCrLf)
TextBox1.Value = ""
for i = 0 to Ubound(xArr)
If Trim(xArr(i)) <> "" Then
TextBox1.value = TextBox1.value & xArr(i) & vbCrLf
End If
Next
Looks like your RegEx code is actually intended for VB.Net rather than VBA, the code below replaces n blank lines with 1 in VBA.
Dim RE As Object: Set RE = CreateObject("VBScript.RegExp")
With RE
.MultiLine = True
.Global = True
.Pattern = "(\r\n)+"
resultString = .Replace(subjectString, vbCrLf)
MsgBox resultString
End With
Of course if you only ever have 2 blank lines you can simply:
resultString = replace$(subjectString, vbcrlf & vbcrlf, vbcrlf)
I know this is old but here's a regex Public Function i made to help. Theres probably a better way but this was simple for me and worked.
'=================================================================================='
Public Function RegExReplace(TextContent As String, SearchEx As String, Optional ReplaceEx As String = "", Optional _
EmptyLines As Boolean = False, Optional TrimLines As Boolean = True) As String
Dim regEx As Object, strOutput As String
Set regEx = CreateObject("vbscript.regexp")
With regEx: .Global = True: .IgnoreCase = False: .MultiLine = True: .Pattern = SearchEx: End With
TextContent = regEx.Replace(TextContent, ReplaceEx)
If EmptyLines = False Then TextContent = RegExReplace(TextContent, "\r\n\r\n", "", True, False)
If TrimLines = True Then TextContent = Trim(TextContent)
RegExReplace = TextContent: Set regEx = Nothing
End Function
'=================================================================================='
If for whatever reason you'd prefer to avoid using RegEx (working on a Mac where VBScript isn't available for example), here's a purely VB approach:
Sub Test()
Call TakeOutTheEmpties(ActiveWindow.Selection.ShapeRange(1))
End Sub
Sub TakeOutTheEmpties(oSh As Shape)
Dim oPara As TextRange
Dim x As Long
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
For x = oSh.TextFrame.TextRange.Paragraphs.Count To 1 Step -1
Set oPara = oSh.TextFrame.TextRange.Paragraphs(x)
If oPara.Text = vbCr Then
oPara.Delete
End If
Next
End If
End If
End Sub

Check which rows a formula refers to in Excel (error checking with VBA)

Is there a way to use VBA to list all the rows a formula refers to?
I have built a spreadsheet that should only refer to cells in the same row, and any formulas referring to a different row are in error. I cannot work out how to do this in VBA. As an example, the third formula would be in error.
=(D3+F3)/(E3+D3)
=D4/E4
=D5^E5+F12
=D6+F6^G6
Ok, i can understand the reason you want to check if formula refer for single row only...
Here's what i wrote. Please, read comments in code.
Option Explicit
Sub CheckFormulas()
Dim c As Range
Dim wsh As Worksheet
Dim sformula As String
'context
Set wsh = ThisWorkbook.Worksheets(1)
'loop through the set of cells in UsedRange
For Each c In wsh.UsedRange
'formula starts with "="
If c.Formula Like "=*" Then
sformula = c.Formula
'check if formula refer to single row
'if not, change background color form this cell
If DoesFormulaReferToSingleRow(sformula) Then
c.Interior.Color = vbRed
End If
End If
Next
End Sub
'needs reference to MS VBScript Regular Expression 5.5
' MS Scripting RunTime
Function DoesFormulaReferToSingleRow(sFormulaToCheck As String) As Boolean
Dim bRetVal As Boolean, sPattern As String
Dim re As VBScript_RegExp_55.RegExp, mc As VBScript_RegExp_55.MatchCollection, m As VBScript_RegExp_55.Match
Dim oDict As Scripting.Dictionary
bRetVal = False
sPattern = "\d{1,}"
Set re = New VBScript_RegExp_55.RegExp
With re
.Global = True
.MultiLine = False
.Pattern = sPattern
Set mc = .Execute(sFormulaToCheck)
End With
Set oDict = New Scripting.Dictionary
For Each m In mc
If Not oDict.Exists(m.Value) Then
oDict.Add m.Value, m.Length
End If
Next
bRetVal = Not (oDict.Count = 1)
Exit_DoesFormulaReferToSingleRow
On Error Resume Next
Set m = Nothing
Set mc = Nothing
Set re = Nothing
Set oDict = Nothing
DoesFormulaReferToSingleRow = bRetVal
Exit Function
Err_DoesFormulaReferToSingleRow:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_DoesFormulaReferToSingleRow
End Function
As you can see, i used Regex and Dictionary object. Do not formget to add references.
For further details, about above objects, please see:
Regex - syntax
Creating a Regular Expression
Microsoft Beefs Up VBScript with Regular Expressions

Wildcard use within Replace - Specific number of characters

I have the following problem:
I want to replace a link to another sheet. This link changes during the Macro from "MeasData!E10" to "MeasData_XXX!E10" (XXX any number) and can be any of these during the Macro. Now I want to replace one of these with a Cell of the current sheet.
The problem is, that my cells contain more than one of the strings like above, e.g.:
=MeasData_110!E10*MeasData_110!E15*MeasData_110!E20
When using the Cells.Replace method this will correctly replace MeasData_110!E10 with the set string. However, if the link I am looking for is not in the first position, e.g.:
=MeasData_110!E20*MeasData_110!E10*MeasData_110!E15
It will be replaced to:
=STRING*MeasData_110!E15
because I am just using a wildcard:
Worksheets(1).Cells.Replace _
What:="MeasData*!E10", Replacement:=STRING
I have not yet found out if there is a wildcard for
a) specific letters
AND
b) specific/variable number of letters (0-4)
Someone got a solution?
I think the quickest way is to use Replace() in a loop:
Sub MM()
Dim foundCell As Excel.Range
Dim foundAddress As String
Dim findString As String
Dim replaceString As String
findString = "MeasData!E10"
replaceString = Range("AD48").Value
Set foundCell = Sheets(1).Cells.Find(What:=findString, LookIn:=xlFormulas, LookAt:=xlPart)
If Not foundCell Is Nothing Then
foundAddress = foundCell.Address
Do
With foundCell
.Formula = Replace(.Formula, findString, replaceString)
End With
Set foundCell = Sheets(1).Cells.FindNext(foundCell)
Loop While Not foundCell Is Nothing
End If
End Sub
Or
You can, if you wish, use the VBScript.RexExp object via late binding like so:
Function ReplaceAllWith(old_string As String, pattern As String, new_string As String) As String
With CreateObject("VBScript.RegExp")
.pattern = pattern
.Global = True
If .Test(old_string) Then
ReplaceAllWith = .Replace(old_string, new_string)
Else
ReplaceAllWith = old_string
End If
End With
End Function
Insert the above into your module, and use like so:
For Each cell In Sheets(1).UsedRange.Cells
If cell.HasFormula Then
cell.Formula = ReplaceAllWith(cell.Formula, "MeasData(_[\d]{3})?!E10", Range("AD48").Value)
End If
Next
If you know the cell numbers you can use the below
Dynamically pass values for the variables Cells1,cells2 and cells3
cells1 = "110!E10"
cells2 = "110!E15"
Cells3 = "110!E20"
str1 = "=MeasData_" & cells1 & "*Measdata_" & cells2 & "*MeasData_" & Cells3
'Debug.Print str1 'Print and verify if you need
Have you tried regular expressions? you need to add reference to Microsoft VBScript regular expressions 5.5 for this
Sub test()
Dim a As String
a = "=MeasData_110!E20*Measdata_110!E10*MeasData_110!E15*Measdata_123!E10"
a = ReplaceNumbers(a, "MeasData_STRING!E10")
MsgBox a
End Sub
Private Function ReplaceNumbers(inputString As String, replacement As String) As String
Pattern = "Meas[dD]ata_([0-9]{1,})\!E10"
output = inputString
Dim re As New RegExp
re.Pattern = Pattern
re.Global = True: re.MultiLine = True
If re.test(inputString) Then
ReplaceNumbers = re.Replace(inputString, replacement)
Else
ReplaceNumbers = inputString
End If
End Function

Extracting text to table without special characters

this script is going to extract each text between () from whole string. Now i would prepare it as a function because many string will be taking under that then i would like to add each extracted words inside table/or list. Each of extracted texts between () should be without special characters which sometimes could occur inside text and i would like to cut them of the string (i would like only to stay A-Z a-z 0-9 how could i do it all?
Sub Main()
Dim s$
s = "hsus(irt)bla dsd (got)(rifk)"
Debug.Print extract_value(s)
End Sub
Public Function extract_value$(s$)
Dim returnS$
Dim v
v = Split(s, Chr(40))
For Each Item In v
If InStr(Item, Chr(41)) Then
returnS = returnS & Chr(32) & Split(Item, ")")(0)
End If
Next
extract_value = Trim$(returnS)
End Function
When parsing you can use a helper function to check for just letters and numbers using the ASCII encoding.
Function validChr(chr As String) as Boolean
Dim ascCode As Integer
ascCode = Asc(chr)
If ascCode >= 65 And ascCode <= 90 Then 'Uppercase
validChr = True
ElseIf ascCode >= 97 And ascCode <= 122 Then 'Lowercase
validChr = True
ElseIf ascCode >= 48 And ascCode <= 57 Then 'Numbers
validChr = True
Else
validChr = False
End Function
You can also look at using RegEx.
This two stage `Regexp`
Converts hsus(ir%$%^t)bla dsd (g°ot)(rifk) to ir%$%^t g°ot rifk
In a single shot ir%$%^t g°ot rifkto irt got rifk
test sub
Sub Main()
Dim strTest As String
strTest = "hsus(ir%$%^t)bla dsd (g°ot)(rifk)"
MsgBox GrabIt(strTest)
End Sub
main sub
Function GrabIt(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.*?)\)"
.Global = True
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
GrabIt = GrabIt & Chr(32) & objRegM.submatches(0)
Next
End If
.Pattern = "[^\w|\s]+"
GrabIt = .Replace(GrabIt, vbNullString)
End With
End Function

How to change a cell depending on content in VBA

I have a lot of cells that contain some numbers and other non-relevant characters. For example cell may look like: 65f or as 11,345asd.
My goal is to delete everything but numbers in these cells, so I could use these numbers for further calculations. I have found a lot of similar questions on different sites, but they are quite specific and I still don't understand how to do it properly.
So the question is how to use change cells or maybe even a range of cells depending on contents? I have some ideas how to do it using string function Replace. But nothing that looks good.
Thanks!
Another way using RegExp
Adding Reference
Add a reference to Microsoft VBScript Regular Expressions 5.5. See image below
CODE: Paste this in a module
Option Explicit
Function GetNumbers(rng As Range) As Variant
Dim StrSample As String
Dim myRegExp As RegExp
Dim myMatches As MatchCollection
Dim myMatch As Match
StrSample = rng.Value
Set myRegExp = New RegExp
With myRegExp
.Pattern = "[^0-9]"
.IgnoreCase = True
.Global = True
End With
Set myMatches = myRegExp.Execute(StrSample)
For Each myMatch In myMatches
Debug.Print myMatch.Value
StrSample = Replace(StrSample, myMatch.Value, "")
Next
GetNumbers = StrSample
End Function
SCREENSHOT:
EDIT
Here is a shorter version which doesn't use looping at all.
Function GetNumbers(rng As Range) As Variant
Dim myRegExp As RegExp
Set myRegExp = New RegExp
myRegExp.Pattern = "[^0-9]"
myRegExp.Global = True
GetNumbers = myRegExp.Replace(rng.Value, "")
End Function
A wee function
public function TONUM(str As string) As string
dim i As long
for i = 1 To len(str)
if not mid$(str, i, 1) Like "[0-9]" then mid$(str, i, 1) = "?"
next
TONUM = replace$(str, "?", "")
end function