How can I remove all characters from inputbox, leaving just numbers?
I have a macro that runs down a column removing white space, shortening to 13 digits but I also need it to remove any text characters.
I still think a regexp is the way to go.
Function removeAlpha(strData As String) As String
strData = Replace(strData, " ", "")
With CreateObject("vbscript.regexp")
.Pattern = "[A-Za-z]"
.Global = True
removeAlpha = .Replace(strData, "")
End With
End Function
And to test:
Sub TestClean()
Const strTest As String = "qwerty123 456 uiops"
MsgBox removeAlpha(strTest)
End Sub
An alternate method to using a regular expression is:
Public Sub removeCharacters()
For Each RANGE_UNASSIGNED In Worksheets(1).Range("A1:A" & Worksheets(1).Range("A1").End(xlDown).Row)
STRING_OUTPUT = ""
For INTEGER_STEP = 1 To Len(RANGE_UNASSIGNED.Value)
STRING_TEMPORARY = Mid(RANGE_UNASSIGNED.Value, INTEGER_STEP, 1)
If STRING_TEMPORARY Like "[a-z.]" Or STRING_TEMPORARY Like "[A-Z.]" Then
STRING_xOUTPUT = ""
Else
STRING_xOUTPUT = STRING_TEMPORARY
End If
STRING_OUTPUT = STRING_OUTPUT & STRING_xOUTPUT
Next INTEGER_STEP
RANGE_UNASSIGNED.Value = STRING_OUTPUT
Next RANGE_UNASSIGNED
End Sub
This should remove all alpha characters from your cell(s). You can remove additional characters if required.
An approach based on IsNumeric.
Sub Keep_If_IsNumeric()
For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
Set c = Cells(j, 1)
strc = ""
For i = 1 To Len(c.Value)
n = Mid(c.Value, i, 1)
If Not IsNumeric(strc & n & "0") Then
Else
strc = strc & n
End If
Next
c.Offset(, 1) = strc
c.Offset(, 2) = Val(Replace(strc, ",", "."))
Next
End Sub
Related
I've already written a code that inserts a space between text and numbers, separating 'unspaced' days and months from dates, and it works as it's supposed to.
The only problem is that I'm using an If then structure to determine which Regular Expressions pattern I should use.
If the first character of the date is a number, then knowing that it is in the 'DayMonth' sequence, I use this pattern: "(.*\d)(?! )(\D.*)". Otherwise, assuming that it isn't in the 'DayMonth' sequence but rather in the 'MonthDay' sequence, I use the other pattern: "(.*\D)(?! )(\d.*)".
Is there any way to use two patterns at once for the Regular Expressions object to scan through so that I can get rid of the If Then structure?
My code below:
Sub SpaceMonthDayIf()
Dim col As Range
Dim i As Long
Set col = Application.InputBox("Select Date Column", "Obtain Object Range", Type:=8)
With CreateObject("VBScript.RegExp")
For i = 1 To Cells(Rows.Count, col.Column).End(xlUp).Row
If IsNumeric(Left(Cells(i, col.Column).Value, 1)) Then
.Pattern = "(.*\d)(?! )(\D.*)"
Cells(i, col.Column) = .Replace(Cells(i, col.Column), "$1 $2")
Else
.Pattern = "(.*\D)(?! )(\d.*)"
Cells(i, col.Column) = .Replace(Cells(i, col.Column), "$1 $2")
End If
Next
End With
End Sub
For clarity, here's what happens when I run my code:
Try this code
Sub Test()
Dim a, i As Long
With Range("A2", Range("A" & Rows.Count).End(xlUp))
a = .Value
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(\d+)"
For i = 1 To UBound(a, 1)
a(i, 1) = Application.Trim(.Replace(a(i, 1), " $1 "))
Next i
End With
.Columns(2).Value = a
End With
End Sub
You can avoid that by inserting your space differently. Here is a Function written with early-binding, but you can change that to late-binding.
Match the junction between a letter and a number, then construct a string, inserting a space appropriately.
Option Explicit
Function InsertSpace(S As String) As String
Const sPat As String = "[a-z]\d|\d[a-z]"
Dim RE As RegExp, MC As MatchCollection
Set RE = New RegExp
With RE
.Global = False
.Pattern = sPat
.IgnoreCase = True
If .Test(S) = True Then
Set MC = .Execute(S)
With MC(0)
InsertSpace = Left(S, .FirstIndex + 1) & " " & Mid(S, .FirstIndex + 2)
End With
End If
End With
End Function
You can also accomplish this without using Regular Expressions:
EDIT Pattern change for Like operator
Option Explicit
Option Compare Text
Function InsertSpace2(S As String) As String
Dim I As Long
For I = 1 To Len(S)
If Mid(S, I, 2) Like "#[a-z]" Or Mid(S, I, 2) Like "[a-z]#" Then
InsertSpace2 = Left(S, I) & " " & Mid(S, I + 1)
Exit Function
End If
Next I
End Function
I was wondering how to remove duplicate names/text's in a cell. For example
Jean Donea Jean Doneasee
R.L. Foye R.L. Foyesee
J.E. Zimmer J.E. Zimmersee
R.P. Reed R.P. Reedsee D.E. Munson D.E. Munsonsee
While googling, I stumbled upon a macro/code, it's like:
Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
xChar = VBA.Mid(xValue, i, 1)
If xDic.exists(xChar) Then
Else
xDic(xChar) = ""
xOutValue = xOutValue & xChar
End If
Next
RemoveDupes1 = xOutValue
End Function
The macro is working, but it is comparing every letter, and if it finds any repeated letters, it's removing that.
When I use the code over those names, the result is somewhat like this:
Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno
By looking at the result I can make out it is not what I want, yet I got no clue how to correct the code.
The desired output should look like:
Jean Donea
R.L. Foye
J.E. Zimmer
R.P. Reed
Any suggestions?
Thanks in Advance.
Input
With the input on the image:
Result
The Debug.Print output
Regex
A regex can be used dynamically iterating on the cell, to work as a Find tool. So it will extract only the shortest match. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*, e.g.: \w*(Jean)\w*
The Regex's reference must be enabled.
Code
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
EXTRACTELEMENT = 0
On Error GoTo 0
End Function
Sub test()
Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
str = Range("A" & Row)
F_str = ""
N_Elements = UBound(Split(str, " "))
If N_Elements > 0 Then
For k = 1 To N_Elements + 1
strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
With objRegExp
.Pattern = strPattern
.Global = True
End With
If objRegExp.test(strPattern) Then
Set objMatches = objRegExp.Execute(str)
If objMatches.Count > 1 Then
If objRegExp.test(F_str) = False Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
ElseIf k <= 2 And objMatches.Count = 1 Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
End If
Next k
Else
F_str = str
End If
Debug.Print Trim(F_str)
Next Row
End Sub
Note that you can Replace the Debug.Print to write on the target
cell, if it is column B to Cells(Row,2)=Trim(F_str)
Explanation
Function
You can use this UDF, that uses the Split Function to obtain the element separated by spaces (" "). So it can get every element to compare on the cell.
Loops
It will loop from 1 to the number of elements k in each cell and from row 1 to lastrow.
Regex
The Regex is used to find the matches on the cell and Join a new string with the shortest element of each match.
This solution operates on the assumption that 'see' (or some other three-letter string) will always be on the end of the cell value. If that isn't the case then this won't work.
Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String
'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))
'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x
'if it's more than one, set to str, otherwise error
If ct > 1 Then
RemoveDupeInCell = str
Else
RemoveDupeInCell = "#N/A"
End If
End Function
I am trying to search for special characters in a string.
If the special character exists in the string then the code would return a false to the adjacent cell.
Dim arr(5)
arr(1) = "19"
arr(2) = "26"
arr(3) = "29"
arr(4) = "32"
arr(5) = "50"
'control characters check
For n = 1 To 5
For x = 1 To 41
If InStr(1, Range("b" & arr(n)), Chr(x)) = 0 Then
For y = 123 To 255
If InStr(Range("b" & arr(n)).Value, Chr(y)) > 0 Then
Range("e" & arr(n)).Value = "FALSE"
Exit For
Else
Range("e" & arr(n)).Value = "TRUE"
End If
Next y
Else
Range("e" & arr(n)).Value = "FALSE"
Exit For
End If
Next x
Next n
My problem is, just looping a few times took quite a long time, is there a faster way to loop through all the data saving more time?
An example of the string data in the cell is : TY56D-CAT131BP342AC46-eL-W-00
Try this:
Sub Test()
Dim arr(5) As String
Dim iLen As Integer, strV As String
Dim Found As Boolean: Found = False
Dim Test As Variant
arr(1) = "19"
arr(2) = "26"
arr(3) = "29"
arr(4) = "32"
arr(5) = "50"
For x = 1 To 5
iLen = Len(Range("B" & arr(x)).Value)
strV = Range("B" & arr(x)).Value
For i = 1 To iLen
Select Case Asc(Mid$(strV, i, 1))
Case 1 To 41, 123 To 255
Found = True
Exit For
End Select
Next i
If Found = False Then
Range("E" & arr(x)).Value = "TRUE"
Else
Found = False
Range("E" & arr(x)).Value = "FALSE"
End If
Next x
End Sub
Calculation time is nearly instant. What differs to your method is, that i go through every characters and then check if its allowed or not. In this case the Select Case can do this much quicker than a for loop for every unallowed char.
It looks like you're being slowed down a lot by referring to
Range("b" & arr(n)).Value
potentially up to 120+ times in the loop (which is itself nested in other loops)
What should immediately improve the speed of your macro is to transfer the Range value to a variable before this loop, for example:
dim search_string as string
search_string = Range("b" & arr(n)).Value
For y = 123 To 255
If InStr(search_string, Chr(y)) > 0 Then
Range("e" & arr(n)).Value = "FALSE"
You'd also save a bit of time converting your whole search range to an array and working on that, but that would take more work, whereas this is a quick change you can make which should drastically improve performance
Try this:
Sub CheckCharacters()
Dim cl(5) As Integer, n As Integer
cls = Array(19, 26, 29, 32, 50)
For n = 0 To 4
If IsValidString(Range("B" & cls(n))) Then
Range("B" & cls(n)).Offset(0, 3) = "TRUE"
Else
Range("B" & cls(n)).Offset(0, 3) = "FALSE"
End if
Next n
End Sub
Function IsValidString(str As String) As Boolean
Dim objRegEx As Object
Set objRegEx = CreateObject("vbscript.regexp")
objRegEx.Pattern = "^[\x2a-\x7a]+"
objRegEx.Global = True
objRegEx.IgnoreCase = True
IsValidString = objRegEx.test(str)
End Function
The important bit is:
"^[\x2a-\x7a]+"
This is a Regex that is only TRUE if the string only contains characters between ASCII values 42 and 122 (which is what you want).
I have:
nuid="!,#,a-z"
But I do not want the double quotes. I want nuid=!,#,a-z
Suggest me ways to remove the start and end quotes
Here is my code:
sub highlight(nuid as string)
dim sh3 as worksheet
Set sh3 = Thisworkbook.Worksheets("Sheet1")
sh3.Select
Cells.Find("User ID").Select
ActiveCell.Offset(1, 0).Select
nuid = Replace(nuid, """", "")
Set rn = sh3.UsedRange
k = rn.Rows.Count + rn.Row - 1
For x = 1 To k
If ActiveCell.Value Like nuid Then
Selection.Interior.Color = vbYellow
Else
Selection.Interior.ColorIndex = xlNone
End If
ActiveCell.Offset(1, 0).Select 'moves activecell down one row.
Next
end sub
From my gui, i will enter special characters which will be stored in the variable nuid.I want only the special characters and not the quotes around it
Also you can try:
nuid = Replace(nuid, Chr(34), vbNullString)
But you can have problem if quotes not the first nor the last character, for example: "!,#,"a-z".
In that case you can try:
nuid = Mid(nuid, 2, Len(nuid) - 1) This will cut the first and last character
Edit:
It seems to me that the quotes that you see indicates the type of a variable string.
Edit2 - watch window
Results:
Edit3 - with sub 4 Sagi:
Sub Highlight4Sagi(SpecChar As String)
Dim Column As Integer
SpecChar = "!##"
ThisWorkbook.Worksheets(1).Select
Column = Cells.Find("User ID").Column
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 2 To LastRow 'loop each row in column "User ID"
For j = 1 To Len(SpecChar) 'loop every specchar: ! and # and # and find him in each cells
If InStr(1, Cells(i, Column), Mid(SpecChar, j, 1)) > 0 Then
Cells(i, Column).Interior.ColorIndex = 6
Exit For
Else
Cells(i, Column).Interior.ColorIndex = 0
End If
Next j
Next i
End Sub
Proper Function:
Sub Test()
Debug.Print RemoveOuterQuotes(Cells(2, 1).Value)
End Sub
Public Function RemoveOuterQuotes(ByVal Str As String) As String
If Left(Str, 1) = """" Then
Str = Right(Str, Len(Str) - 1)
End If
If Right(Str, 1) = """" Then
Str = Left(Str, Len(Str) - 1)
End If
'Debug.Print Str
'Stop
RemoveOuterQuotes = Str
End Function
Basically escape a " with ""
Below should help
nuid = replace (nuid, """", "")
additional variant
Sub highlight(nuid As String)
Dim sh3 As Worksheet, Cl&, Lrow&, x&, oCell As Range
Set sh3 = ThisWorkbook.Worksheets("Sheet1")
Cl = sh3.Cells.Find("User ID").Column
Frow = sh3.Cells.Find("User ID").Row + 1
Lrow = Cells.Find("*", , , , xlByRows, xlPrevious).Row
For Each oCell In sh3.Range(Cells(Frow, Cl), Cells(Lrow, Cl))
If oCell.Value <> "" Then
For x = 1 To Len(nuid)
If oCell.Value Like "*" & Mid(nuid, x, 1) & "*" Then
oCell.Interior.Color = vbYellow
Exit For
Else
oCell.Interior.Color = xlNone
End If
Next x
End If
Next oCell
End Sub
output
but if you need to find, for instance the cells which contain any char in low case [a-z] then another aproach should be used
I have the code of this macro which removes leading and trailing spaces in cells with text or numbers:
Sub LIMPIAR()
Dim i As Integer
For i = 2 To 20628
Cells(i, 7).Value = Trim(Cells(i, 6).Value)
Next
End Sub
However , there are cells which its content is " ". So I would like to convert that kind of cells to "". How Can I do that?
EDIT: I'm working with scraped data.
Maybe dealing with them like this can help:
If Len(Cells(i,6).Value) <= 2 Then Cells(i, 7).Value = "" End If
OR
If Cells(i,6).Value = " " Then Cells(i, 7).Value = "" End If
Not a very elagent solution, but I would make use of the split function and then reconcatenate the elements of the resulting array. Assuming your string is in cell A1,
mystring = ""
myarray = Split(Cells(1, 1), " ")
For i = LBound(myarray) To UBound(myarray)
If Trim(myarray(i)) <> "" Then
mystring = mystring & Trim(myarray(i)) & " "
End If
Next i
MsgBox Trim(mystring)
mystring should provide a string with just one space between words. You could put this code inside your loop.