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
Related
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...
I've used VBA to filter out values from a different sheet and I'm thinking of how best to format it for readability.
I've merged similar values and would like to select the corresponding rows for each alternating merged cell and apply a color fill.
Here is a visual for reference:
And this is the code I've used to get to the current state.
Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.DisplayAlerts = False
For i = lRow To 7 Step -1
If Cells(i, 2) = Cells(i - 1, 2) Then
Range(Cells(i, 2), Cells(i - 1, 2)).Merge
End If
Next i
Application.DisplayAlerts = True
Is there a way of inserting formatting within the loop or otherwise? I'm also open to other ways of making the table more readable.
PS: The image I've attached is just for reference. The actual table I'm working with has tons of rows and columns so readability is important.
Except for the merging of cells the code below does what you want. Instead of merging the code effectively hides the duplicate item titles.
Option Explicit
Sub FormatData()
' 28 Feb 2019
Const CaptionRow As Long = 1
Const FirstDataRow As Long = 3 ' assuming row 2 to contain subtitles
Const FirstDataClm As String = "B" ' change as appropriate
Const DescClm As String = "D" ' change as appropriate
Dim Desc As Variant, PrevDesc As Variant
Dim Col() As Variant, ColIdx As Boolean
Dim FontCol As Long
Dim Rng As Range
Dim Rl As Long, Cl As Long ' last Row / Column
Dim R As Long
Rl = Cells(Rows.Count, DescClm).End(xlUp).Row
Cl = Cells(CaptionRow, Columns.Count).End(xlToLeft).Column
Col = Array(15261367, 15986394) ' sky, pale: change as required
FontCol = Cells(FirstDataRow, FirstDataClm).Font.Color
Application.ScreenUpdating = False
For R = FirstDataRow To Rl
Desc = Cells(R, DescClm).Value
If Desc = PrevDesc Then
Set Rng = Rng.Resize(Rng.Rows.Count + 1)
Else
If Not Rng Is Nothing Then
SetColouring Rng, DescClm, Col(Abs(ColIdx)), FontCol
ColIdx = Not ColIdx
End If
Set Rng = Range(Cells(R, FirstDataClm), Cells(R, Cl))
End If
PrevDesc = Desc
Next R
SetColouring Rng, DescClm, Col(Abs(ColIdx)), FontCol
Application.ScreenUpdating = True
End Sub
Private Sub SetColouring(Rng As Range, _
ByVal C As String, _
ByVal Col As Long, _
ByVal Fcol As Long)
' 28 Feb 2019
Dim R As Long
With Rng
.Interior.Color = Col
.Font.Color = Fcol
For R = 2 To .Rows.Count
.Cells(R, Columns(C).Column - .Column + 1).Font.Color = Col
Next R
End With
End Sub
There are some constants at the top of the code which you can modify. Note also that the font color you use in the sheet is presumed to be found in the first used cell of the sheet as specified by the constants.
Observe that the entire code runs on the ActiveSheet. I strongly urge you to change that bit and specify a sheet, preferably both by its name and the workbook it is in. If you regularly use the code as published above its just a matter of time before you apply it to a worksheet which gets damaged as a result.
I am writing a small timesaver tool that inserts various text values in a column based on a cell offset of the location of a list-based text search in column C.
Dim C1 As Range
Set C1 = Range("B:B").Find("Value to search")
If C1 Is Nothing Then
Else
C1.Offset(0, -1).Value = "Text value to insert"
End If
I am certain there is a better way to write this relatively simple proc in a more scalable way rather than hard code each value to search in the code, but am not sure how this could be simplified further. I've been looking at the first two lines, and I may be wrong, but I believe a cell range needs to be defined as written in the first two lines in order for the Offset to know the cell location to offset from.
Depends on how you are planning on running this. You could have it as a sub that prompts a user to enter the search value and the text to input at offset. I show that below. It is easy enough instead to adapt to a loop if you have the search and offset strings in the sheet. I use only the populated area of column B for the search. The search values and insert/offset values are held in variables.
Option Explicit
Public Sub AddText()
Dim searchValue As String, insertValue As String, C1 As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
searchValue = Application.InputBox("Please supply search value", Type:=2)
insertValue = Application.InputBox("Please supply insert value", Type:=2)
If searchValue = vbNullString Or insertValue = vbNullString Then Exit Sub 'or loop prompting for entry
With ws
Set C1 = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Find(searchValue)
End With
If Not C1 Is Nothing Then C1.Offset(0, -1).Value = insertValue
End Sub
Edit:
From your comment you are actually just doing a VLOOKUP.
In sheet 2 A1 put the following and autofill down for as many rows as are filled in column B.
=IFERROR(VLOOKUP(B1,Sheet1!A:B,2,FALSE),"")
Same thing using arrays and a dictionary
Option Explicit
Public Sub AddText()
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim lookupArray(), updateArray(), lookupDict As Object, i As Long
Set lookupDict = CreateObject("Scripting.Dictionary")
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsSearch = ThisWorkbook.Worksheets("Sheet2")
With wsSource
lookupArray = .Range("A1:B" & GetLastRow(wsSource, 1)).Value
End With
For i = LBound(lookupArray, 1) To UBound(lookupArray, 1)
lookupDict(lookupArray(i, 1)) = lookupArray(i, 2)
Next
With wsSearch
updateArray = .Range("A1:B" & GetLastRow(wsSearch, 2)).Value
For i = LBound(updateArray, 1) To UBound(updateArray, 1)
If lookupDict.Exists(updateArray(i, 2)) Then
updateArray(i, 1) = lookupDict(updateArray(i, 2))
End If
Next
.Cells(1, 1).Resize(UBound(updateArray, 1), UBound(updateArray, 2)) = updateArray
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
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
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