Replace any letter [A-Z] in a range with vba - excel

I have a free text field that contains both text and numbers of varying lengths. I need to replace any letter in the column with "x". I have had success with replacing specific text using 'rng.replace' but need to include any letter [A-Z]
Dim rng as Range, lastRow As Long
lastRow = ActiveSheet.Range("A" & Rows.Count).Emd(xlUp).Row
Set rng = ActiveSheet.Range("E2:E" & lastRow)
rng.replace What:=[A-Z], Replacement:="x", MatchCase:=False
I cannot get the correct syntax for "What" to match any and all letters A-Z
Any help would be appreciated. I have a loop that works, however, it is very slow and stalling my overall process too much. I have worked the above rng.replace into speeding up the process for everything except this "text" replace.

Plenty of ways to skin a cat it seems.
Dim Number As Long
Dim Letter As String
Set Rng = Range("A1")
For Number = 1 To 28
Letter = Split(Cells(1, Number).Address, "$")(1)
Rng.Replace What:=(Letter), Replacement:="x", MatchCase:=False
Number = Range(Letter & 1).Column
Next

If performance is an issue, it's usually faster to do this by checking the byte values of the string array. Something like this:
Public Function ReplaceAlphas(txt As String) As String
Dim i As Long, a As Long
Dim b() As Byte
b = txt
For i = 0 To UBound(b) Step 2
a = b(i)
If (a >= 65 And a <= 90) Or (a >= 97 And a <= 122) Then
b(i) = 120
End If
Next
ReplaceAlphas = b
End Function

Try the next function, please:
Function removeLetters(strX As String) As String
With CreateObject("vbscript.regexp")
.Pattern = "[^0-9]" 'pattern to replace everything except numbers
.Global = True
removeLetters = .Replace(strX, "X")
End With
End Function
To use it for a range, please try the next code:
Sub testRngRemoveLetters()
Dim sh As Worksheet, rng As Range, C As Range, usedCol As Long, lastRow As Long
Set sh = ActiveSheet ' use here your sheet
usedCol = 2 'column B:B. Use the column number you need
lastRow = sh.cells(Rows.count, usedCol).End(xlUp).Row 'last row on the chosen column
'building the range to be processed:
Set rng = sh.Range(sh.cells(2, usedCol), sh.cells(lastRow, usedCol))
'Use the above function to replace everything else then numbers:
For Each C In rng
C.value = removeLetters(C.value)
Next
End Sub
Please, test it and send some feedback...

Related

I just tried to do multiple filtering using the below code. but am able to get the row number only at the first and after that am unable

Sub SplitWords()
Dim TextStrng As String
Dim Result() As String
Sheets("CO REPORT").Select
TextStrng = Range("K6").Value
Result() = Split(TextStrng)
For i = LBound(Result()) To UBound(Result())
Sheets("RSVP SCOPE").Select
'ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$G$791").AutoFilter Field:=1, Criteria1:="=*" &
Result(i) & "*", Operator:=xlOr
MsgBox Result(i)
Worksheets("RSVP SCOPE").Range("1:1").EntireRow.Hidden = True
Set Report = Excel.ActiveSheet
Dim visRng As Range
Set visRng = Report.UsedRange.SpecialCells(xlCellTypeVisible)
Dim r As Range
Dim j As Integer
For Each r In visRng.Rows
j = r.row
MsgBox (j)
Worksheets("RSVP SCOPE").Range("1:1").EntireRow.Hidden = False
ActiveSheet.Range("$A$1:$G$791").AutoFilter.ShowAllData
Next
Next i
End Sub
For the above code, the split words is being used since there will be multiple words in a single cell. I need to copy a text from sheet1 and search that value in column 1 of sheet2 . Now after filtering I need to display the row number for every selected words. In the above code, the first iteration gets executed successfully. But for the second iteration I get a
Your question is broken. I see trouble:
...
' Dim r As Range
Dim r As Variant
...

Concatenate the values in one column separated by '/' based on the values assigned to the another column

I have an excel sheet which contains two columns called ProductName and CountryCode.i wanted to concatenate all the CountryCode separated by / based on the corresponding values in the column 'ProductName' and My output would be obtained in a separate column called 'FinalResults'. Please note that I used remove duplicate function to get unique values in Column C from Column A.
I tried the below VBA code with the help of stackoverflow and got the results.
Sub ProductCountry()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long
Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
ws.Range("C2").Delete Shift:=xlShiftUp
Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)
For Each SearchCell In Names
Set FoundCell = SearchRange.Find(SearchCell)
For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
MyString = MyString & FoundCell.Offset(, 1) & "/"
Set FoundCell = SearchRange.FindNext(FoundCell)
Next i
SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
MyString = ""
Next SearchCell
End Sub
Seems it works fine except for the first product PRO1. You could see it didn't concatenate the codes orderly and skipped the country code US and took the country code SG two times instead.
Can anyone help what went wrong in this script and I also got range error sometime if I use this same code for large data.
I rewrote it ...
Public Function ConcatenateCodes(ByVal strProductName As String, ByVal rngCells As Range, Optional ByVal strDelimiter As String = "/") As String
Application.Volatile
Dim objCell As Range, lngRow As Long, lngCol As Long, strThisProductName As String
Dim strCountry As String, lngBlank As Long
For lngRow = 1 To rngCells.Rows.Count
strThisProductName = Trim(rngCells.Cells(lngRow, 1))
strCountry = Trim(rngCells.Cells(lngRow, 2))
If strThisProductName & strCountry = "" Then
lngBlank = lngBlank + 1
Else
lngBlank = 0
If strProductName = strThisProductName Then
ConcatenateCodes = ConcatenateCodes & strDelimiter & strCountry
End If
End If
If lngBlank = 10 Then Exit For
Next
If ConcatenateCodes <> "" Then ConcatenateCodes = Mid(ConcatenateCodes, 2)
End Function
... I'm comfortable with the above but that's just me. It means the data doesn't need to be sorted and it will work.
Add the formula to your cell and watch it go.
If you concern about speed you should use arrays to handle your data:
Option Explicit
Public Sub CollectList()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'read values into array
Dim InputValues() As Variant
InputValues = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1)).Value
Dim UniqueList As Object
Set UniqueList = CreateObject("Scripting.Dictionary")
'collect all products in a dictionary
Dim iRow As Long
For iRow = 1 To UBound(InputValues, 1)
If UniqueList.Exists(InputValues(iRow, 1)) Then
UniqueList(InputValues(iRow, 1)) = UniqueList(InputValues(iRow, 1)) & "/" & InputValues(iRow, 2)
Else
UniqueList.Add InputValues(iRow, 1), InputValues(iRow, 2)
End If
Next iRow
'output dictionary into cells
iRow = 2 'start output in row 2
Dim itm As Variant
For Each itm In UniqueList
ws.Cells(iRow, "C").Value = itm
ws.Cells(iRow, "D").Value = UniqueList(itm)
iRow = iRow + 1
Next itm
End Sub
As can be seen by the other responses, there are many ways to accomplish your task.
But read VBA HELP for the Range.Find method
I submit the following to help you understand where you went wrong:
This is your problem line:
Set FoundCell = SearchRange.Find(SearchCell)
You only specify the what argument for the Find. So other arguments default to some uncontrolled value. In general, the after argument will default to the beginning of the range, so the first matching term you will Find for PRO1 will be in A3. Also, the 2nd SG is being picked up because the lookat is defaulting to xlPart and PRO1 is contained within PRO10.
So one way of correcting that portion of your code, would be to be sure to specify all the relevant arguments of the Find. eg:
Set FoundCell = SearchRange.Find(what:=SearchCell, after:=SearchRange.End(xlDown), lookat:=xlWhole)

Shortening words based on database in Excel VBA

I am currently trying to replace words in a cell with shorter versions in mass. I have a dictionary of words to make shorter and will have a column of cells that need to have one or more of the words shortened.
I am very new to VBA and I'm not sure how I would go about this. I tried searching and found some that would be changing text in a word doc but nothing from Excel to excel, at least with my search terms.
I have added a picture here of the Idea, the Text to be shortened is in column A, the words that can be shortened are in column C and the shortened versions are in column D.
Sample
Here's a full sub version if that works better for you
Sub ReplaceViaList()
Dim ws As Worksheet
Dim repRng As Range
Dim x As Long, lastRow As Long
Dim repCol As Long, oldCol As Long, newCol As Long
Dim oldStr As String, newStr As String
'screenupdating/calc
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'define worksheet
Set ws = ActiveSheet
'define columns to work with
repCol = 1 'col A
oldCol = 3 'col C
newCol = 4 'col D
'find last row of replacement terms
lastRow = ws.Cells(ws.Rows.Count, repCol).End(xlUp).Row
'set range of items to be replaced
Set repRng = ws.Range( _
ws.Cells(2, repCol), _
ws.Cells(lastRow, repCol) _
)
'loop through cells in replacement terms
For x = 2 To ws.Cells(ws.Rows.Count, oldCol).End(xlUp).Row
'define replacement terms
oldStr = ws.Cells(x, oldCol).Value
newStr = ws.Cells(x, newCol).Value
'replace
repRng.Replace What:=oldStr, Replacement:=newStr
Next x
'screenupdating/calc
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
You can use this UDF.
Function SubstituteMultiple(text As String, old_text As Range, new_text As Range)
Dim i As Single
For i = 1 To old_text.Cells.Count
Result = Replace(LCase(text), LCase(old_text.Cells(i)), LCase(new_text.Cells(i)))
text = Result
Next i
SubstituteMultiple = Result
End Function
Place this code in your regular module. then write this formula =SubstituteMultiple(A2,$C$2:$C$11,$D$2:$D$11) in cell B2 and drag it to the bottom.
Perhaps simple replace in VBA would do it,
Sub test()
Dim searchval As Variant
Dim replaceval As Variant
searchval = Range("C1:C10")
replaceval = Range("D1:D10")
For i = 1 To 10
Columns("A:A").Replace What:=searchval(i, 1), Replacement:=replaceval(i, 1), LookAt:=xlPart
Next i
End Sub

Excel invisible question mark

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

Excel VBA Find last row number where column "C" contains a known value

Seeking a method in Excel VBA to Find last row number where column "C" contains a known value.
This will find the last occurrence of happiness in column C
Sub SeekHappiness()
Dim C As Range, where As Range, whatt As String
whatt = "happiness"
Set C = Range("C:C")
Set where = C.Find(what:=whatt, after:=C(1), searchdirection:=xlPrevious)
MsgBox where.Address(0, 0)
End Sub
To output the row number only, use:
MsgBox Mid(where.Address(0, 0), 2)
To find the first occurrence:
Sub SeekHappiness()
Dim C As Range, where As Range, whatt As String
whatt = "happiness"
Set C = Range("C:C")
Set where = C.Find(what:=whatt, after:=C(1))
MsgBox where.Address(0, 0)
End Sub
You could loop through the column to find the last occurrence of a value.
Sub findLastRow()
Dim searchValue As String
Dim endRow As Integer
Dim lastRowSearchValue As Integer
searchValue = "testValue" ''enter your search value
With Worksheets("sheet1") ''enter the name of your worksheet
endRow = .Cells(Rows.Count, 3).End(xlUp).Row
For i = 1 To endRow
If .Cells(i, 3) = searchValue Then
lastRowSearchValue = i
End If
Next i
End With
End Sub
Just replace the value of the variable "searchValue" with whatever is the value you're looking for (maybe change the type of the variable if its not a string) and the Sub will store the index of the last row of the occurrence of the searchValue in the variable "lastRowSearchValue" for further use.
Sub GetRo()
'Either select data or replace selection with your range
Debug.Print Selection.Find(what:="mysring", searchdirection:=xlPrevious).Row
End Sub

Resources