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
Related
I was using this code and it was working perfectly on small amount of data. It works both way if the data is filtered or not.
Dim cell As Range
Dim i As Integer
Dim specialCharacters As String
specialCharacters = " !##$%^&*()_+-=[]{};':"",.<>/?\|"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each cell In Selection
For i = 1 To Len(specialCharacters)
cell.Value = Replace(cell.Value, Mid(specialCharacters, i, 1), "")
Next i
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
But when i convert this code into arrays found the issue that is when it pastes the data to the cells it was exact copy of the above cells and some of them gives an error #NA. I hope someone can help me to fix the issue.
Sub RemoveSpecialCharacters()
Dim cellValues As Variant
Dim i As Long, j As Long
Dim specialCharacters As String
specialCharacters = " ':"",.<>/?|"
Application.ScreenUpdating = FALSE
Application.Calculation = xlCalculationManual
Dim filteredRange As Range
Set filteredRange = Selection.SpecialCells(xlCellTypeVisible)
If Not filteredRange Is Nothing Then
For Each Area In filteredRange.Areas
cellValues = Area.value
For i = 1 To UBound(cellValues, 1)
For j = 1 To UBound(cellValues, 2)
Dim value As String
value = cellValues(i, j)
For k = 1 To Len(specialCharacters)
value = Replace(value, Mid(specialCharacters, k, 1), "")
Next k
cellValues(i, j) = value
Next j
Next i
Area.value = cellValues
Next Area
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = TRUE
End Sub
Instead of looping cell-by-cell, try using Range.Replace here. The following is semi-tested:
Sub RemoveSpecialCharacters(ByVal rng As Range)
Dim specialCharacters As String
specialCharacters = " !##$%^&*()_+-=[]{};':"",.<>/?\|"
Dim wildcards As String
wildcards = "?~*"
Dim i As Long
For i = 1 To Len(specialCharacters)
Dim specialCharacter As String
specialCharacter = Mid$(specialCharacters, i, 1)
' Escape wildcards using the ~
If InStr(wildcards, specialCharacter) > 0 Then
specialCharacter = "~" & specialCharacter
End If
rng.Replace _
What:=specialCharacter, _
Replacement:="", _
LookAt:=xlPart
Next
End Sub
Call it like the following:
RemoveSpecialCharacters rng:=Selection
or
RemoveSpecialCharacters rng:=Selection.Cells(xlCellTypeVisible)
Note that Selection.Cells(xlCellTypeVisible) may return unexpected results if Selection is a single cell.
In that case, use:
If Selection.CountLarge > 1 Then
RemoveSpecialCharacters rng:=Selection.Cells(xlCellTypeVisible)
Else
RemoveSpecialCharacters rng:=Selection
End If
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 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 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
In an Excel 2007 VB Macro, I'm trying to do is take a comma separate String, split it, and then reduce it, removing duplicate consecutive values. So "2,2,2,1,1" would become "2,1", or "3,3,3,2,3,3,3" would become "3,2,3".
It looks like it should work, but when it gets to the "If currentVal.equals(prevVal) = False Then", it his a runtime error 424, 'Object required'.
It's been forever since I did any VB, and that was VP6.
Sheets("Sheet1").Select
Range("I1").Select
Dim data() As String
Dim currentVal, prevVal As String
Dim output As String
Dim temp As Boolean
Do Until Selection.Value = ""
data = Split(Selection, ",")
output = ""
prevVal = ""
For Each elem In data
currentVal = CStr(elem)
If currentVal.equals(prevVal) = False Then
output = output + elem + ","
End If
Next elem
Selection.Value = output
Selection.Offset(1, 0).Select
Loop
There's a few problems. First, you can't use:
Dim currentVal, prevVal As String
You must use:
Dim currentVal as String
Dim prevVal As String
or:
Dim currentVal as String, prevVal as String
...as you can't shortcut types in VBA unfortunately. Secondly, strings aren't objects in VBA so there's no .equals (or any other method). You want:
If currentVal <> prevVal Then
Lastly, you need to set prevVal at the end of your loop or your code won't work as expected.
EDIT Here's some working code:
Dim data() As String
Dim currentVal As String, prevVal As String
Dim output As String
Dim temp As Boolean
Do Until Selection.Value = ""
data = Split(Selection, ",")
output = ""
prevVal = ""
For Each elem In data
currentVal = CStr(elem)
If currentVal <> prevVal Then
output = output + elem + ","
End If
prevVal = currentVal
Next elem
Selection.Value = output
Selection.Offset(1, 0).Select
Loop
I’d suggest using a variant array with a regular expression to maximise the efficiency and speed of your approach. Something like this
Update: Picking up on my own advice elsewhere the code now test for more than 1 cell before applying the variant array
Sub Clear()
Dim ws As Worksheet
Dim rng1 As Range
Dim X
Dim lngRow As Long
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
Set ws = Sheets("Sheet1")
Set rng1 = ws.Range(ws.[i1], ws.Cells(Rows.Count, "I").End(xlUp))
With objRegex
.Global = True
.Pattern = "(\d)(,(\1))+"
If rng1.Cells.Count > 1 Then
X = rng1
For lngRow = 1 To UBound(X)
X(lngRow, 1) = .Replace(X(lngRow, 1), "$1")
Next lngRow
rng1 = X
Else
rng1.Value = .Replace(rng1.Value, "$1")
End If
End With
End Sub
You could use a dictionary object especially since you are moving the numbers to a text file it doesn't matter that they are not treated as numbers per se. See this question