I need to remove data from cells that is 9 or more digits or characters. For example this should be deleted: 123456789, 987654321, 1234567898765, and so on.
I already got the code that checks every single part of a cell to compare but I have a problem constructing the number specification.
The sample line for code to work on will look like that:
Aegis Transformation Cycle 566609354 Agent 73849496753
My code:
For g = 2 to RowNumber
MyCell = " " & Cells(g, 2).Value & " "
Word = Split(MyCell, " ")
For j = 0 To UBound(Word)
If Word >= 100000000 Then
Cells(g, 2).Replace What:=Word(j), Replacement:=""
End If
Next j
Next g
One way is using regular expressions.
Sub x()
Dim r As Range
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d{9,}"
For Each r In Range("A1:A10")
r.Offset(, 1) = .Replace(r, "")
Next r
End With
End Sub
You could also use the Len() function with Trim() like so:
Sub DeleteBlanks()
Dim g As Long, RowNumber As Long
With Sheets("SheetName")
'Finds the last row in the first column
RowNumber = .Cells(Rows.Count, 1).End(xlUp).Row
For g = 1 To RowNumber
'Note:Value2 reads cells W/O formatting and is faster
If Len(Trim(.Cells(g, 1).Value2)) >= 9 Then
.Cells(g, 1).ClearContents
End If
Next g
End With
End Sub
You could achieve this quite easily with Regular Expressions. The following code will identify any part of your string that contains a number equal to or longer than 9 characters and remove them
Public Sub Demo()
Dim RegExp As Object
Dim rng As Range
Dim matches
Dim c
Set rng = Sheet1.Range("A1")
Set RegExp = CreateObject("vbscript.regexp")
With RegExp
.MultiLine = False
.Global = True
.IgnoreCase = False
.Pattern = "[0-9]{9,}"
For Each c In rng
If .test(c) Then
Set matches = .Execute(c)
MsgBox .Replace(c, vbNullString)
End If
Next c
End With
End Sub
Related
I need a VBA line of code to check if a cell contains a year if this format 199[0-9] OR 20[0-2][0-2].
The code loops from the first row in Column A to the last row in the sheet.
Something like this:
finalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = finalRow To 2 Step -1
If InStr(1, Cells(i, 1), "199[0-9]" OR "20[0-2][0-2]") = 0 Then
Range("A" & i).EntireRow.Delete
End If
I appreciate your cooperation.
Thank You
Consider using the regular expression library to evaluate the year patterns. The object can store the pattern and later evaluate it against the cell values in your loop.
Example:
Option Explicit
Sub example()
' Setup Regular Expression Object
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Pattern = "199[0-9]|20[0-2][0-2]" ' Define pattern here
' Delete rows that match year pattern
Dim i As Integer, ws As Worksheet, finalRow As Integer
Set ws = ThisWorkbook.Worksheets("Sheet1")
finalRow = ws.Range("A1").CurrentRegion.Rows.Count
For i = finalRow To 1 Step -1
If RegEx.test(Cells(i, 1)) Then
ws.Rows(i).EntireRow.Delete
End If
Next i
End Sub
Please, try the next function. It returns all occurrences, if more than one:
Private Function containsYear(x As String) As Variant
Dim regEx As New RegExp, strPattern As String, strInput As String
Dim matchC As MatchCollection, arr() As Long, El, k As Long
strPattern = "([0-9]{4})" 'search for 4 consecutive numbers
If strPattern <> "" Then
strInput = x
With regEx
.Global = True: .MultiLine = True
.IgnoreCase = False: .Pattern = strPattern
End With
If regEx.Test(strInput) Then
Set matchC = regEx.Execute(strInput)
ReDim arr(matchC.count - 1)
For Each El In matchC
If CLng(El) >= 1990 And CLng(El) <= 2022 Then
arr(k) = El: k = k + 1
End If
Next
ReDim Preserve arr(k - 1)
containsYear = arr()
Else
containsYear = Array("no Match")
End If
End If
End Function
It can be checked in this way:
Sub testContainsYear()
Dim x As String, arr() As Long, El
x = "This year, 2021 is better than 2020."
x = "This year, 2021 is better than 1890." 'comment it to check the above line...
arr = containsYear(x)
If UBound(arr) = 0 Then
If arr(0) <> "no Match" Then
Debug.Print "Found a year: " & arr(0)
Else
Debug.Print "No any year could be found..."
End If
Else
For Each El In arr
Debug.Print "Found year " & El
Next
End If
End Sub
If you do not need to return the occurrences, it can return a boolean (True). please, use the next function, in such a case:
Private Function containsYear(x As String) As Boolean
Dim regEx As New RegExp, strPattern As String, strInput As String
Dim matchC As MatchCollection, arr() As Long, El, k As Long
strPattern = "([0-9]{4})" 'search for 4 consecutive numbers
If strPattern <> "" Then
strInput = x
With regEx
.Global = True: .MultiLine = True
.IgnoreCase = False: .Pattern = strPattern
End With
If regEx.Test(strInput) Then
Set matchC = regEx.Execute(strInput)
ReDim arr(matchC.count - 1)
For Each El In matchC
If CLng(El) >= 1990 And CLng(El) <= 2022 Then
containsYear = True: Exit Function
End If
Next
Else
containsYear = False
End If
End If
End Function
It can be tested as:
Sub testContainsYear()
Dim x As String, arr() As Long, El
x = "This year, 2021 is better than 2020."
x = "This year, 1542 was better than 1890." 'comment it to check the above line...
Debug.Print containsYear(x)
End Sub
To use the function for processing the existing values in A:A column, should be simple. Declare a range variable rngDel where to keep cells when the function returns True. Firstly, set the range, then using Union and delete all rows at the end (`If Not rngDel Is Nothing Then rngDel.EntireRow.Delete'). If not clear enough, I can help with the code, too.
I have an excel column with cell values as string mixed with some numbers ar the end. I am not able to do a 'Text to column' as space cannot be a delimiter nor tab.I tried the below code but it works only if the entire cell is a only digits
I am a beginner in macros and vb
Sub ReplaceNoX()
Dim cell As Object
Dim val As String
Dim i As Integer
Dim n As String
Application.ScreenUpdating = False
For Each cell In Selection
If IsNumeric(cell.Value) Then
val = cell.Text
For i = 1 To Len(val)
n = Mid(val, i, 1)
If "0" <= n And n <= "9" Then
Mid(val, i, 1) = "x"
End If
Nextf
cell.Formula = val
End If
Next
Application.ScreenUpdating = True
End Sub
If you do want to replace every digit with an 'x', here is a different approach using regular expressions.
Sub Regex1()
Dim oRgx As Object, rCell As Range
Set oRgx = CreateObject("VBScript.RegExp")
With oRgx
.Global = True
.Pattern = "\d"
For Each rCell In Selection
rCell.Value = .Replace(rCell, "x")
Next rCell
End With
End Sub
If you want to change both numbers and mixed text and numbers, then remove the IsNumeric() test:
Sub ReplaceNoX()
Dim cell As Range
Dim val As String
Dim i As Long
Dim n As String
Application.ScreenUpdating = False
For Each cell In Selection
val = cell.Text
For i = 1 To Len(val)
n = Mid(val, i, 1)
If n Like "[0-9]" Then
Mid(val, i, 1) = "x"
End If
Next i
cell.Value = val
Next
Application.ScreenUpdating = True
End Sub
NOTE:
use Long rather than Integer
use Like to check individual characters.
use Range rather than Object
I have strings that look like this:
DTTGGRKDVVNHCGKKYKDK
RKDVVNHCGKKYKDKSKRAR
What I want to do is to highlight the region with bold and red font.
Resulting this:
I tried the following code using LIKE operator in Excel VBA but it breaks
at this line Set MC = .Execute(C.Text)
Option Explicit
Sub boldSubString()
Dim R As Range, C As Range
Dim MC As Object
Set R = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
For Each C In R
C.Font.Bold = False
If C.Text Like "KK*K" Or C.Text Like "KR*R" Then
Set MC = .Execute(C.Text)
C.Characters(MC(0).firstindex + 1, MC(0).Length).Font.Bold = True
End If
Next C
End Sub
What's the right way to do it?
I'm using Mac Excel Version 15.31
Without Regular Expressions, you can try the following. I've not tested it extensively but it does seem to work even with multiple matching substrings within the same string.
Examine VBA HELP for the functions that are being used, so you understand how this works, and also how to construct proper patterns to be used with the Like operator, in case you need to expand the list of possible patterns.
Option Explicit
Sub boldSS()
Dim WS As Worksheet
Dim R As Range, C As Range
Dim sPatterns(1) As String
Dim I As Long, J As Long
sPatterns(0) = "KR?R"
sPatterns(1) = "KK?K"
Set WS = Worksheets("sheet1")
With WS
Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each C In R
'Reset to default
With C.Font
.Bold = False
.Color = vbBlack
End With
For I = 0 To UBound(sPatterns)
If C Like "*" & sPatterns(I) & "*" Then
For J = 1 To Len(C) - Len(sPatterns(I)) + 1
If Mid(C, J, Len(sPatterns(I))) Like sPatterns(I) Then
With C.Characters(J, Len(sPatterns(I))).Font
.Bold = True
.Color = vbRed
End With
If J < Len(C) - 3 Then
J = J + 3
Else
Exit For
End If
End If
Next J
End If
Next I
Next C
End Sub
Using your regex pattern equivalent instead for the Like operator, you can rewrite the above as below. Note that your Regex pattern will also match KKAR, and KRAK (as does the macro below, but not the one above).
Option Explicit
Sub boldSS()
Dim WS As Worksheet
Dim R As Range, C As Range
Dim sPattern As String
Dim I As Long
sPattern = "K[KR]?[KR]"
Set WS = Worksheets("sheet1")
With WS
Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each C In R
With C.Font
.Bold = False
.Color = vbBlack
End With
If C Like "*" & sPattern & "*" Then
For I = 1 To Len(C) - 4 + 1
If Mid(C, I, 4) Like sPattern Then
With C.Characters(I, 4).Font
.Bold = True
.Color = vbRed
End With
If I < Len(C) - 3 Then
I = I + 3
Else
Exit For
End If
End If
Next I
End If
Next C
End Sub
SubString problems could be complicated, once one drills a bit in them. E.g., in the OP example, the substring KKYKDKSK also is a correct substring of KK*K, thus, it probably could be color coded as well.
In general, with some limitations the task, like searching for non-overlapping substrings and considering that the substring is present once per string, this is possible:
With some hardcoding of the variables and checking only for KK*K, this is how the main method looks like:
Option Explicit
Sub TestMe()
Dim myRange As Range: Set myRange = Worksheets(1).Range("A1:A2")
Dim myCell As Range
For Each myCell In myRange
myCell.Font.Bold = False
Dim subString As String
subString = findTheSubString(myCell.Value2, "KK*K")
Debug.Print myCell.text, subString
ChangeTheFont subString, myCell, vbBlue
Next myCell
End Sub
The function findTheSubString() takes the 2 strings and returns the substring, which is to be color-coded later:
Public Function findTheSubString(wholeString As String, subString As String) As String
Dim regEx As Object
Dim inputMatches As Object
Dim regExString As String
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = Split(subString, "*")(0) & "[\s\S]*" & Split(subString, "*")(1)
.IgnoreCase = True
.Global = True
Set inputMatches = .Execute(wholeString)
If regEx.test(wholeString) Then
findTheSubString = inputMatches(0)
Else
findTheSubString = "Not Found!"
End If
End With
End Function
The last part is to change the font of a specific substring in Excel range, thus the arguments are a string and a range:
Sub ChangeTheFont(lookFor As String, currentRange As Range, myColor As Long)
Dim startPosition As Long: startPosition = InStr(1, currentRange.Value2, lookFor)
Dim endPosition As Long: endPosition = startPosition + Len(currentRange.Value2)
With currentRange.Characters(startPosition, Len(lookFor)).Font
.Color = myColor
.Bold = True
End With
End Sub
I have an extracted information from a system into an Excel file.
The names "Leone" seem the same but Excel recognize it differently.
Leone
Leone
The length of the string is not the same, and if I check the value with VBA an invisible ? is the first character.
Could you help me how to get rid of the invisible characters?
To get rid of all invisible ? you may try this.
Sub CleanUnicode()
Dim n As Long, strClean As String, strChr As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet3") 'change Sheet3 to data sheet
For Each cel In ws.Range("A1:A10") 'change A1:A10 to working range
strClean = cel.Value
For n = Len(strClean) To 1 Step -1
strChr = Mid(strClean, n, 1)
If AscW(strChr) = 8203 Then '? is unicode character 8203
strClean = Replace(strClean, strChr, "")
End If
Next
cel.Value = WorksheetFunction.Trim(strClean)
Next cel
End Sub
Instead of If AscW(strChr) = 8203 Then you can also use If AscW(strChr) > 255 Then.
EDIT 1 : As per the suggestion of #YowE3K. Assuming you only have Unicode 8203 in cells to be replaced.
Sub CleanUnicode()
Dim n As Long, strClean As String, strChr As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet3") 'change Sheet3 to data sheet
For Each cel In ws.Range("A1:A10") 'change A1:A10 to working range
cel.Value = Replace(cel.Value, ChrW(8203), "")
Next cel
End Sub
Got this from here.
In general this is strange - this is how chrome renders the HTML from the question:
This is a workaround, that checks the characters of the string and builds a new one if one of them is equal to 63. Pretty much like a simple replace function:
Public Function removeInvisible(rngRange As Range) As String
Dim cnt As Long
For cnt = 1 To Len(rngRange)
If AscW(Mid(rngRange, cnt, 1)) <> 8203 Then
removeInvisible = removeInvisible & Mid(rngRange, cnt, 1)
End If
Next cnt
End Function
If the text has come from a copy/paste it might have taken in some other non printable characters.
These might be displayed in the VBA editor as ? which is often the way that unicode characters are rendered when the font does not support them.
I would try the formula
=CODE(LEFT(A3,1)) in one of the cells to see what the Unicode code point of the invisible character was.
If it turns out to be a non ascii chat then you could write a macro to strip out the characters that are problematic based on their code values.
To remove multiple occurrences of non-ascii characters from all cells of your range you can use this.
Option Explicit
Sub test()
Dim regEx As Object
Dim temparray() As String
Dim myrange As Range
Dim lrow As Long
Dim lcol As Long
Dim counter As Long
Dim i As Long
Dim j As Long
Set regEx = CreateObject("vbscript.regexp")
With regEx
.Pattern = "[^\u0000-\u007F]"
.MultiLine = False
.Global = True
.IgnoreCase = False
End With
'set your last row and column
lrow = 5
lcol = 5
ReDim temparray(1 To lrow, 1 To lcol)
Set myrange = Sheets("Sheet1").Range(Cells(1, 1), Cells(lrow, lcol))
Application.ScreenUpdating = False
counter = 0
For i = 1 To lrow
For j = 1 To lcol
temparray(i, j) = regEx.Replace(myrange.Cells(i, j).Value, "")
counter = counter + 1
Next j
Next i
myrange.Value = temparray
Application.ScreenUpdating = True
End Sub
I have a column with data in the following format:
xxxx(yyyy)
I want to remove what is inside the parentheses, and the parentheses themselves.
You can readily cater for multiple replacements in one string with a Regexp
Sub Test()
Debug.Print CleanStr("xxxx(yyyy)")
Debug.Print CleanStr("and me ()")
Debug.Print CleanStr("and me ()` second string(aaa)")
End Sub
clean string
Function CleanStr(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\([^)]*\)"
.Global = True
CleanStr = .Replace(strIn, vbNullString)
End With
End Function
I would use a regular expression for this job:
Sub DeleteMatches()
Dim cell As Range, re As Object
' define the regular expression to match "(...)" '
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "\([^)]*\)" ' matches "(...)" '
' iterate and clean each cell in range "C2:C100" '
For Each cell In Range("C2:C100")
cell.Value = re.Replace(cell.Value, Empty)
Next
End Sub
Try this:
=LEFT(A1,FIND("(",A1)-1)
Select the cells you wish to process and run this short macro:
Sub DataGrabber()
Dim r As Range
For Each r In Intersect(ActiveSheet.UsedRange, Selection)
If InStr(1, r.Value, "(") > 0 Then
r.Value = Split(r.Value, "(")(0)
End If
Next r
End Sub
Dim x
x = Split("xxxx(yyyy)", "(")
Dim result
result = x(0)