Hi
This is a leave roster updated in this format. I need to take the sum of the numbers (inside brackets).
The list goes on i can't change the format now, appreciate if anyone can help with calculating the sum using a formula.
If you have access to TEXTJOIN function, you can use following array formula for any count of parentheses:
=SUM(IFERROR(FILTERXML("<a><b>" & SUBSTITUTE(SUBSTITUTE(TEXTJOIN("",TRUE,A2:L3),"(","#</b><b>"),")","</b><b>") & "</b></a>","//b"),0))
Array formula after editing is confirmed by pressing ctrl + shift + enter
A solution without helper columns and a maximum of 2 pairs of parentheses would be this ARRAY FORMULA: CTRL + SHIFT + ENTER
=SUM(
VALUE(MID(A1:A2,SEARCH("(",A1:A2)+1,SEARCH(")",A1:A2)-SEARCH("(",A1:A2)-1)),
IFERROR(VALUE(MID(A1:A2,SEARCH("(",A1:A2,SEARCH("(",A1:A2)+1)+1,SEARCH(")",A1:A2,SEARCH(")",A1:A2))-SEARCH("(",A1:A2)-1)),0)
)
Adapt the ranges to your needs.
If you can use vba, try using the user-defined function below.
Function mySum(rngDB As Range)
Dim mCol As Object 'MatchCollection
Dim Ws As Worksheet
Dim rng As Range
Dim strPattern As String
Dim s As String
Dim i As Integer, n As Integer
Dim vSum() As Variant
Application.Volatile
Set Ws = ActiveSheet
strPattern = "(()([0-9]{1,})())"
For Each rng In rngDB
s = rng.Value
Set mCol = GetRegEx(s, strPattern)
If Not mCol Is Nothing Then
For i = 0 To mCol.Count - 1
n = n + 1
ReDim Preserve vSum(1 To n)
vSum(n) = Val(mCol.Item(i))
Next i
End If
Next
If n Then
mySum = WorksheetFunction.Sum(vSum)
End If
End Function
Function GetRegEx(StrInput As String, strPattern As String) As Object
Dim RegEx As Object 'New RegExp
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Global = True
.IgnoreCase = False
.MultiLine = True
.Pattern = strPattern
End With
If RegEx.test(StrInput) Then
Set GetRegEx = RegEx.Execute(StrInput)
End If
End Function
image
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 am looking for a way to extract addresses / ranges from a formulae. I have created an example formula below.
=SUMIFS(Worksheet_Name!$C$3:$C$20, Worksheet_Name!$A$3:$A$20, "Blue", Worksheet_Name!$B$3:$B$20, "Green")
I am trying to get some sort VBA routine which I can pick apart the formulae.
I would like to get the ranges as follows:
Worksheet_Name!$C$3:$C$20
Worksheet_Name!$A$3:$A$20
Worksheet_Name!$B$3:$B$20
So I can access these separately.
How about the following, this will take a cell as input, then it will strip out anything outside the brackets and split the remainder of the formula by commas into an array, and then it will display then in a Msgbox, but you can adapt that to your needs:
Sub Get_Ranges_In_Formula()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare the worksheet you are working with
Dim rngs As String
Dim arrayofRngs
cellvalue = ws.Range("A1").Formula
'get the formula from the cell
openingParen = InStr(cellvalue, "(")
closingParen = InStrRev(cellvalue, ")")
rngs = Mid(cellvalue, openingParen + 1, closingParen - openingParen - 1)
'strip anything outside the brackets
arrayofRngs = Split(rngs, ",")
'split by comma into array
For i = LBound(arrayofRngs) To UBound(arrayofRngs)
If InStr(arrayofRngs(i), "!") > 0 Then MsgBox arrayofRngs(i)
Next
End Sub
A solution using RegEx to extract cell references from formulas:
Sub Get_Ranges_In_Formula()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim xRetList As Object
Dim xRegEx As Object
Dim I As Long
Dim xRet As String
Dim Rg As Range
Set Rg = ws.Range("A1")
Application.Volatile
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
With xRegEx
.Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
Set xRetList = xRegEx.Execute(Rg.Formula)
If xRetList.Count > 0 Then
For I = 0 To xRetList.Count - 1
MsgBox xRetList.Item(I)
Next
End If
End Sub
Try this
Sub Test()
Dim e, s As String
s = MyArguments(Range("A1"))
For Each e In Split(s, ",")
If InStr(e, "!") Then Debug.Print Trim(e)
Next e
End Sub
Function MyArguments(rng As Range) As String
MyArguments = Split(Split(rng.Formula, "(")(1), ")")(0)
End Function
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 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)