I have a lot of cells that contain some numbers and other non-relevant characters. For example cell may look like: 65f or as 11,345asd.
My goal is to delete everything but numbers in these cells, so I could use these numbers for further calculations. I have found a lot of similar questions on different sites, but they are quite specific and I still don't understand how to do it properly.
So the question is how to use change cells or maybe even a range of cells depending on contents? I have some ideas how to do it using string function Replace. But nothing that looks good.
Thanks!
Another way using RegExp
Adding Reference
Add a reference to Microsoft VBScript Regular Expressions 5.5. See image below
CODE: Paste this in a module
Option Explicit
Function GetNumbers(rng As Range) As Variant
Dim StrSample As String
Dim myRegExp As RegExp
Dim myMatches As MatchCollection
Dim myMatch As Match
StrSample = rng.Value
Set myRegExp = New RegExp
With myRegExp
.Pattern = "[^0-9]"
.IgnoreCase = True
.Global = True
End With
Set myMatches = myRegExp.Execute(StrSample)
For Each myMatch In myMatches
Debug.Print myMatch.Value
StrSample = Replace(StrSample, myMatch.Value, "")
Next
GetNumbers = StrSample
End Function
SCREENSHOT:
EDIT
Here is a shorter version which doesn't use looping at all.
Function GetNumbers(rng As Range) As Variant
Dim myRegExp As RegExp
Set myRegExp = New RegExp
myRegExp.Pattern = "[^0-9]"
myRegExp.Global = True
GetNumbers = myRegExp.Replace(rng.Value, "")
End Function
A wee function
public function TONUM(str As string) As string
dim i As long
for i = 1 To len(str)
if not mid$(str, i, 1) Like "[0-9]" then mid$(str, i, 1) = "?"
next
TONUM = replace$(str, "?", "")
end function
Related
I'm new to VBA and am trying to cobble together some code to allow a user to input a word (or several words) into a cell and then show a list of matching row entries.
I have tried the following code but am getting an "instring = type mismatch" error.
Note that "B3" is the field dedicated for the "search word" and column F is the column containing the text I want to search within. If the word is contained, I want to show that row and hide all rows that don't contain that word.
Sub Find_Possible_Task()
ROW_NUMBER = 0
SEARCH_STRING = Sheets("codeset").Range("B3")
ROW_NUMBER = ROW_NUMBER + 1
ITEM_IN_REVIEW = Sheets("codeset").Range("F:F")
If InStr(ITEM_IN_REVIEW, SEARCH_STRING) Then
Do
Cells(c.Row).EntireRow.Hidden = False
Loop Until ITEM_IN_REVIEW = ""
End If
End Sub
TIA!
Few bad coding conventions or even possibly downright errors:
It's a good practice to explicity declare the scope Public/Private of your Sub procedure
Unless you're passing the variables from some place else, they need to be declared with Dim keyword
Using Option Explicit will help you prevent aforementioned error(s)
(Subjective) variables in all caps are ugly and in most programming languages it is convention to reserve all caps variables names for constants (Const)
Option Explicit
Private Sub keep_matches()
Dim what As Range
Dim where As Range
Dim res As Range ' result
Dim lr As Long ' last active row
Dim ws As Worksheet: Set ws = Sheets("codeset")
lr = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Set what = ws.Range("B3")
Set where = ws.Range("F1:F" & lr)
' we'll create an extra column for a loop in our .Find method
where.Copy
ws.Range("F1").EntireColumn.Insert
ws.Range("F1").PasteSpecial xlPasteValues
where.EntireRow.Hidden = True ' preemptively hide them all
Set where = ws.Range("F1:F" & lr)
Set res = where.Find(what, lookIn:=xlValues) ' ilook for matches, 1st attempt
If Not res Is Nothing Then ' if found
Do Until res Is Nothing ' repeat for all results
res.EntireRow.Hidden = False
res = "Checked"
Set res = where.FindNext(res)
Loop
Else
MsgBox("No matches were found")
where.EntireRow.Hidden = False ' we don't wanna hide anything
End If
ws.Range("F1").EntireColumn.Delete ' remove the extra help column for Find method
End Sub
Should work as expected.
If there are any question, let me know.
instead of instr(), consider range.find().
Sub Find_Possible_Task()
Dim SEARCH_STRING As String
Dim ITEM_IN_REVIEW As Range
Dim found As Range
Dim i As Integer
SEARCH_STRING = Sheets("Sheet1").Range("B3").Value
i = 1
Do
Set ITEM_IN_REVIEW = Sheets("Sheet1").Cells(i, 6)
Set found = ITEM_IN_REVIEW.Find(What:=SEARCH_STRING)
If found Is Nothing Then
ITEM_IN_REVIEW.EntireRow.Hidden = True
End If
i = i + 1
Loop Until ITEM_IN_REVIEW = ""
End Sub
alternatively, consider using filter table:
1. check if your table has filter on ==> if yes, pass. if no, turn on filter.
2. filter column F for keyword to contain value in cell B3.
I have a sheet that I need to remove the spaces from so I can compare it I am using a function I found on here and a sub that puts all the values into an array (for speed) but I cannot get it to work any idea why. I get a
ByRef argument type mismatch error
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
Sub stringRangeToClean()
Dim r As Variant
Dim i As Long
r = ActiveWorkbook.Sheets("Trent BASE DATA").UsedRange
For i = 2 To UBound(r)
r(i, 10).Value2 = RemoveWhiteSpace(r(i, 10))
Next i
End Sub
now trying this have I realised the col I is actually (I,9)
but im getting an error user defined type error on the RegExp line
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
Sub stringRangeToClean()
Dim r As Variant
Dim i As Long
Dim txt As String
r = ActiveWorkbook.Sheets("Trent BASE DATA").UsedRange
For i = 2 To UBound(r)
txt = r(i, 9)
txt = RemoveWhiteSpace(txt)
Next i
End Sub
Here you go, no regex required for simply removing spaces. Your main challenge is just defining your range which is basic VBA:
Sub tgr()
With ActiveWorkbook.Sheets("Trent BASE DATA")
.Range("J2", .Cells(.Rows.Count, "J").End(xlUp)).Replace " ", vbNullString
End With
End Sub
Try like this:
Public Function RemoveWhiteSpace(target As String) As String
Dim RegExp As Object
Set RegExp = CreateObject("VBScript.RegExp")
With RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
This way you are using a late binding for the regExp variable, thus neither you nor your users have to add any additional library.
If you want to use the early binding, you should add the Microsoft VBScript Regular Expressions 5.5" library to the ones, that VBA uses. The early binding gives you some time bonus and it provides IntelliSense.
Here the selected answer explains step-by-step how to add the library:
How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
Concerning your code - this is very simply loop, try to do it:
Sub StringRangeToClean()
Dim r As Variant
Dim myCell As Range
r = ActiveWorkbook.Sheets("Trent BASE DATA").UsedRange
For Each myCell In r
myCell = RemoveWhiteSpace(txt)
Next myCell
End Sub
This way every cell would be examined and the white spaces would be removed.
Is there a way to use VBA to list all the rows a formula refers to?
I have built a spreadsheet that should only refer to cells in the same row, and any formulas referring to a different row are in error. I cannot work out how to do this in VBA. As an example, the third formula would be in error.
=(D3+F3)/(E3+D3)
=D4/E4
=D5^E5+F12
=D6+F6^G6
Ok, i can understand the reason you want to check if formula refer for single row only...
Here's what i wrote. Please, read comments in code.
Option Explicit
Sub CheckFormulas()
Dim c As Range
Dim wsh As Worksheet
Dim sformula As String
'context
Set wsh = ThisWorkbook.Worksheets(1)
'loop through the set of cells in UsedRange
For Each c In wsh.UsedRange
'formula starts with "="
If c.Formula Like "=*" Then
sformula = c.Formula
'check if formula refer to single row
'if not, change background color form this cell
If DoesFormulaReferToSingleRow(sformula) Then
c.Interior.Color = vbRed
End If
End If
Next
End Sub
'needs reference to MS VBScript Regular Expression 5.5
' MS Scripting RunTime
Function DoesFormulaReferToSingleRow(sFormulaToCheck As String) As Boolean
Dim bRetVal As Boolean, sPattern As String
Dim re As VBScript_RegExp_55.RegExp, mc As VBScript_RegExp_55.MatchCollection, m As VBScript_RegExp_55.Match
Dim oDict As Scripting.Dictionary
bRetVal = False
sPattern = "\d{1,}"
Set re = New VBScript_RegExp_55.RegExp
With re
.Global = True
.MultiLine = False
.Pattern = sPattern
Set mc = .Execute(sFormulaToCheck)
End With
Set oDict = New Scripting.Dictionary
For Each m In mc
If Not oDict.Exists(m.Value) Then
oDict.Add m.Value, m.Length
End If
Next
bRetVal = Not (oDict.Count = 1)
Exit_DoesFormulaReferToSingleRow
On Error Resume Next
Set m = Nothing
Set mc = Nothing
Set re = Nothing
Set oDict = Nothing
DoesFormulaReferToSingleRow = bRetVal
Exit Function
Err_DoesFormulaReferToSingleRow:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_DoesFormulaReferToSingleRow
End Function
As you can see, i used Regex and Dictionary object. Do not formget to add references.
For further details, about above objects, please see:
Regex - syntax
Creating a Regular Expression
Microsoft Beefs Up VBScript with Regular Expressions
I have the following problem:
I want to replace a link to another sheet. This link changes during the Macro from "MeasData!E10" to "MeasData_XXX!E10" (XXX any number) and can be any of these during the Macro. Now I want to replace one of these with a Cell of the current sheet.
The problem is, that my cells contain more than one of the strings like above, e.g.:
=MeasData_110!E10*MeasData_110!E15*MeasData_110!E20
When using the Cells.Replace method this will correctly replace MeasData_110!E10 with the set string. However, if the link I am looking for is not in the first position, e.g.:
=MeasData_110!E20*MeasData_110!E10*MeasData_110!E15
It will be replaced to:
=STRING*MeasData_110!E15
because I am just using a wildcard:
Worksheets(1).Cells.Replace _
What:="MeasData*!E10", Replacement:=STRING
I have not yet found out if there is a wildcard for
a) specific letters
AND
b) specific/variable number of letters (0-4)
Someone got a solution?
I think the quickest way is to use Replace() in a loop:
Sub MM()
Dim foundCell As Excel.Range
Dim foundAddress As String
Dim findString As String
Dim replaceString As String
findString = "MeasData!E10"
replaceString = Range("AD48").Value
Set foundCell = Sheets(1).Cells.Find(What:=findString, LookIn:=xlFormulas, LookAt:=xlPart)
If Not foundCell Is Nothing Then
foundAddress = foundCell.Address
Do
With foundCell
.Formula = Replace(.Formula, findString, replaceString)
End With
Set foundCell = Sheets(1).Cells.FindNext(foundCell)
Loop While Not foundCell Is Nothing
End If
End Sub
Or
You can, if you wish, use the VBScript.RexExp object via late binding like so:
Function ReplaceAllWith(old_string As String, pattern As String, new_string As String) As String
With CreateObject("VBScript.RegExp")
.pattern = pattern
.Global = True
If .Test(old_string) Then
ReplaceAllWith = .Replace(old_string, new_string)
Else
ReplaceAllWith = old_string
End If
End With
End Function
Insert the above into your module, and use like so:
For Each cell In Sheets(1).UsedRange.Cells
If cell.HasFormula Then
cell.Formula = ReplaceAllWith(cell.Formula, "MeasData(_[\d]{3})?!E10", Range("AD48").Value)
End If
Next
If you know the cell numbers you can use the below
Dynamically pass values for the variables Cells1,cells2 and cells3
cells1 = "110!E10"
cells2 = "110!E15"
Cells3 = "110!E20"
str1 = "=MeasData_" & cells1 & "*Measdata_" & cells2 & "*MeasData_" & Cells3
'Debug.Print str1 'Print and verify if you need
Have you tried regular expressions? you need to add reference to Microsoft VBScript regular expressions 5.5 for this
Sub test()
Dim a As String
a = "=MeasData_110!E20*Measdata_110!E10*MeasData_110!E15*Measdata_123!E10"
a = ReplaceNumbers(a, "MeasData_STRING!E10")
MsgBox a
End Sub
Private Function ReplaceNumbers(inputString As String, replacement As String) As String
Pattern = "Meas[dD]ata_([0-9]{1,})\!E10"
output = inputString
Dim re As New RegExp
re.Pattern = Pattern
re.Global = True: re.MultiLine = True
If re.test(inputString) Then
ReplaceNumbers = re.Replace(inputString, replacement)
Else
ReplaceNumbers = inputString
End If
End Function
Below is the example set in Excel,
[column1] [column2]
A1 =C3-C5
A2 =((C4-C6)/C6)
A3 =C4*C3
A4 =C6/C7
A5 =C6*C4*C3
I need to extract the used references in formulas
For example,
for "A1", I simply need to get the C3 and C5.
for A2, I need to get the C4 and C6.
This is an update to:
Will work for local sheet references, but not for references off-sheet. – brettdj May 14 '14 at 11:55
By Using Larrys method, just change the objRegEx.Pattern to:
(['].*?['!])?([[A-Z0-9_]+[!])?(\$?[A-Z]+\$?(\d)+(:\$?[A-Z]+\$?(\d)+)?|\$?[A-Z]+:\$?[A-Z]+|(\$?[A-Z]+\$?(\d)+))
This will:
Search for optional External links: (['].*?['!])?
Search for optional Sheet-reference: ([[A-Z0-9_]+[!])?
Do the following steps in prioritized order:
Search for ranges with row numbers (And optional $): \$?[A-Z]+\$?(\d)+(:\$?[A-Z]+\$?(\d)+)?
Search for ranges without row numbers (And optional $): \$?[A-Z]+:\$?[A-Z]+
Search for 1-cell references (And optional $): (\$?[A-Z]+\$?(\d)+)
Resulting in this:
Sub testing()
Dim result As Object
Dim r As Range
Dim testExpression As String
Dim objRegEx As Object
Set r = Cells(1, 2) ' INPUT THE CELL HERE , e.g. RANGE("A1")
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Global = True
objRegEx.Pattern = """.*?""" ' remove expressions
testExpression = CStr(r.Formula)
testExpression = objRegEx.Replace(testExpression, "")
objRegEx.Pattern = "(([A-Z])+(\d)+)" 'grab the address
objRegEx.Pattern = "(['].*?['!])?([[A-Z0-9_]+[!])?(\$?[A-Z]+\$?(\d)+(:\$?[A-Z]+\$?(\d)+)?|\$?[A-Z]+:\$?[A-Z]+|(\$?[A-Z]+\$?(\d)+))"
If objRegEx.test(testExpression) Then
Set result = objRegEx.Execute(testExpression)
If result.Count > 0 Then
For Each Match In result
Debug.Print Match.Value
Next Match
End If
End If
End Sub
Doing this, will give you the values of all possible references, I could think of. (Updated this post, because I needed the problem solved).
This function returns you a comma separated list of source cells (precedents):
Function References(rngSource As Range) As Variant
Dim rngRef As Range
Dim strTemp As String
On Error Resume Next
For Each rngRef In rngSource.Precedents.Cells
strTemp = strTemp & ", " & rngRef.Address(False, False)
Next
If Len(strTemp) 0 Then strTemp = Mid(strTemp, 3)
References = strTemp
End Function
However, please note that you cannot use this as a UDF in the worksheet, as rngRef.Address unfortunately causes a circular reference. However, you can use it in a small procedure to populate another column, e.g.
Sub ShowPrecedents()
Dim rng As Range
'Will paste precedents of A1:A6 into D1:D6
For Each rng In Range("D1:D6")
rng.Value = References(rng.Offset(, -3))
Next
End Sub
Just to provide you an alternative... NOTE THAT THIS will return duplicate result if the cells are called more than once
Sub testing()
Dim result As Object
Dim r As Range
Dim testExpression As String
Dim objRegEx As Object
Set r = Cells(1, 2) ' INPUT THE CELL HERE , e.g. cells("A1")
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Global = True
objRegEx.Pattern = """.*""" ' remove expressions
testExpression = CStr(r.Formula)
testExpression = objRegEx.Replace(testExpression, "")
objRegEx.Pattern = "(([A-Z])+(\d)+)" 'grab the address
If objRegEx.test(testExpression) Then
Set result = objRegEx.Execute(testExpression)
If result.Count > 0 Then
For Each Match In result
Debug.Print Match.Value
Next Match
End If
End If
End Sub
Results are stored in "Match.Value"