Excel VBA: "Change a Subroutine into a Function", for String Conversion - excel

Through my work, and copying others, I have cobbled together a Excel VBA Sub that separates a long sting with groups of (text groups) and (number groups) into a replacement string with spaces in between each seperate group; as per this example:
• “123abc12aedsw2345der”
• …Apply selection Sub() then becomes:
• “123 abc 12 aedsw 2345 der”
It converts the string in its original cell as per the “selection”, so I am currently left with the altered data in is original cell
PROBLEM: I would like to change this into a FUNCTION where the transformed data would appear in the Function cell and leave the original cell intact. I have done hundreds of these but I cannot seem to get this to work as an independent FUNCTION. Below the finished and working Sub Routine I am trying to convert to an independent function to call from anywhere on the worksheet:
Sub SplitTextNumbersSelection()
Dim c As Range
'********** Inserts Space Before Number Groups ******************************
For n = 1 To 10
For Each c In Selection
c = InsertSpace(c.Text)
Next
Next n
'****************Inserts Space Before Letter Groups ***********************
For n = 1 To 10
For Each c In Selection
c = InsertSpace2(c.Text)
Next
Next n
'****************************************
End Sub
Function InsertSpace(str As String) As String
With CreateObject("vbscript.regexp")
.Pattern = "([a-z])(\d)"
'.Pattern = "(\d)([a-z])"
InsertSpace = .Replace(str, "$1 $2")
End With
End Function
Function InsertSpace2(str As String) As String
With CreateObject("vbscript.regexp")
'.Pattern = "([a-z])(\d)"
.Pattern = "(\d)([a-z])"
InsertSpace2 = .Replace(str, "$1 $2")
End With
End Function

Bit simpler:
Function PrepString(v As String)
Dim rv As String, i As Long, c1, c2
For i = 1 To Len(v) - 1
c1 = Mid(v, i, 1)
c2 = Mid(v, i + 1, 1)
If (c1 Like "[a-z]" And c2 Like "[0-9]") Or _
(c2 Like "[a-z]" And c1 Like "[0-9]") Then
rv = rv & c1 & " "
Else
rv = rv & c1
End If
Next i
PrepString = rv & Right(v, 1)
End Function

Related

How to turn general data written as fractions into 3 place decimal numbers. Replace " 0." with "."

I'm trying to turn general data written as fractions like 3/4" or 13 7/32" into 3 place decimal numbers such as 0.750 or 13.219.
I have a working table replacement that handles 0 to 1" fractions. It can't handle the mixed numbers like 13 7/32". It leaves me with 13 0.219 which is why I need to replace " 0." with "." to join the 13 and 219 together with a decimal.
We do this data conversion in multiple steps and hand type because Excel tries converting some fractions like 3/4" into a date.
Original data
Resulting data
Sub FractionConvertMTO()
'this section works
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
Selection.Replace what:=Cells(i, 21).Value, Replacement:=Cells(i, 22).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
'this section doesn't work
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
str1 = " "
str1 = Trim(Replace(str1, " ", "+"))
Next
'this section changes the format.
For i = 66 To 130
Range("F6:H48").NumberFormat = "0.000"
Next
'this section is supposed to add an = sign in front of the cell contents but doesn't work.
Dim Cell As Range
For Each Cell In Range("F6:H48")
Cell.Value = "=" & Cell.Value
Next Cell
'this section works to highlight the first cell
Worksheets("BOM").Cells(1, 1).Select
End Sub
I dug up the following method from my library of useful functions. It converts numbers represented as a fractional string to the numeric equivalent. Simply loop through the cells needing conversion and call this method:
Public Function FractionToNumber(ByVal Value As String, Optional ByVal Digits As Long = 0) As Double
Dim P As Integer
Dim N As Double
Dim Num As Double
Dim Den As Double
Value = Trim$(Value)
P = InStr(Value, "/")
If P = 0 Then
N = Val(Value)
Else
Den = Val(Mid$(Value, P + 1))
Value = Trim$(Left$(Value, P - 1))
P = InStr(Value, " ")
If P = 0 Then
Num = Val(Value)
Else
Num = Val(Mid$(Value, P + 1))
N = Val(Left$(Value, P - 1))
End If
End If
If Den <> 0 Then N = N + Num / Den
FractionToNumber = Round(N, Digits)
End Function
You may also code something like the following:
Sub FractionConvertMTO()
Dim rng As Range
Dim Arr As Variant
Arr = Worksheets("MTO").Range("F6:H48")
For Row = 1 To UBound(Arr, 1)
For col = 1 To UBound(Arr, 2)
str1 = Arr(Row, col)
pos1 = InStr(str1, " ")
pos2 = InStr(str1, "/")
If pos2 = 0 Then
N = val(str1)
Num = 0: Den = 1
Else
If pos1 And pos1 < pos2 Then
N = val(Left$(str1, pos1 - 1))
Num = val(Mid$(str1, pos1 + 1))
Else
N = 0
Num = val(Left$(str1, pos2 - 1))
End If
Den = val(Mid$(str1, pos2 + 1))
End If
Arr(Row, col) = N + Num / Den
Next col
Next Row
Worksheets("MTO").Range("F6", "H48") = Arr
End Sub
If you dispose of the newer dynamic array features (vers. 2019+,MS365) you might write the results in one go to the entire original range (target range) as follows (overwriting the existing range; otherwise define a given offset to identify another target range: rng.Offset(,n)=..).
Tip: make a backup copy before testing (as it overwrites rng)!
Note that this example assumes the " character (asc value of 34).
A) First try via tabular VALUE() formula evaluation
Caveat: converting blanks by VALUE() would be written as #VALUE! results, which would need a further loop. To avoid this you can prefix a zero to the formulae myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))" so that results would be displayed as zero.
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) define tabular formula
Dim myFormula As String
'myFormula = "=VALUE(SUBSTITUTE(" & rng.Address & ","""""""",""""))"
'Alternative to avoid #VALUE! displays for blanks:
myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))"
'Debug.Print myFormula
'3) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value2 = rng.Parent.Evaluate(myFormula)
End Sub
Conclusion due to comment:
Though fast, this approach has a big disadvantage: Excel interpretes date-like numbers as such, transforms them internally to dates by returning the numeric part here, so a cell input of 3/4" would return the corresponding date value of the current year for March 4th.
B) Reworked code based on direct cell evaluations in a loop //Edit
Similar to the above processing this approach is also based on evaluation, but collects all formulae as strings in a variant datafield array v, which allows to manipulate and evaluate each cell input individually:
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) assign formula strings to variant 1-based 2-dim data field array
Dim v As Variant
v = rng.Formula2
'3) evaluate results in a loop
Dim i As Long, j As Long
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
v(i, j) = Evaluate("0" & Replace(v(i, j), Chr(34), ""))
Next j
Next i
'4) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value = v
End Sub
str1 = trim(Replace(str1, "0.", "."))

Simplify parameters of excel formula using VBA

If I have a UDF that has the parameters as such:
=MySampleUDF(150+127.193,1000,240-30-12)
How can I use VBA to reduce the above to this (i.e. calculate & simplify all the parameters):
=MySampleUDF(277.193,1000,198)
I've tried to think of ways that involve Regex, but really there must be a simpler way?
So, you want to Evaluate each parameter in the Formula, and turn it into a single value?
The method below is far from perfect; if your parameter includes a formula, then it will fail (e.g. =MySampleUDF(150+127.193,999+1+PRODUCT(7+3,0),240-30-12) will result in =MySampleUDF(277.193,999+1+PRODUCT(10,0),198)), but it forms an almost-decent starting point, and doesn't require any advanced understanding. There are, undoubtedly, many ways to improve it, with more time.
Sub SimplifyParameters(Target AS Range)
Dim aBrackets AS Variant, bClose As Boolean, aParams AS Variant
Dim lCurrBracket AS Long, lCurrParam As Long, rCurrCell AS Range
Dim sProcessBracket AS String, vEvaluated AS Variant
For Each rCurrCell In Target.Cells 'In case you input more than 1 cell
If Len(rCurrCell.Formula)>0 Then 'Ignore blank cells
aBrackets = Split(rCurrCell.Formula, "(") 'Split by Function
For lCurrBracket = lBound(aBrackets) to UBound(aBrackets)
aProcessBracket = aBrackets(lCurrBracket)
bClose = (Right(sProcessBracket,1)=")")
If bClose Then sProcessBracket = Left(sProcessBracket, Len(sProcessBracket)-1)
aParams = Split(sProcessBracket, ",") 'Split by Parameter
For lCurrParam = lBound(aParams) to uBound(aParams)
vEvaluated - Evaluate(aParams(lCurrParam))
If Not IsError(vEvaluated) Then aParams(lCurrParam) = vEvaluated
Next lCurrParam
aBrackets(lCurrBracket) = Join(aParams, ",") & IIF(bClose, ")", "") 'Recombine Parameters
Next lCurrBracket
rCurrCell.Formula = Join(aBrackets, "(") 'Recombine Functions
End If
Next rCurrCell
End Sub
It Splits the Formula on "(", to separate functions
"=MySampleUDF(150+127.193,1000,240-30-12)"
[0] = "=MySampleUDF"
[1] = "150+127.193,1000,240-30-12)"
Then it goes through those, removes the ")", and Splits them on ","
"=MySampleUDF"
[0] = "=MySampleUDF"
"150+127.193,1000,240-30-12"
[0] = "150+127.193"
[1] = "1000"
[2] = "240-30-12"
Then it runs the Evaluate function on each of those and, if the result is not an error, substitutes it in
Evaluate("=MySampleUDF") = Error 2029
Evaluate("150+127.193") = 277.193
Evaluate("1000") = 1000
Evaluate("240-30-12") = 198
Then it Joins the Parameters back together, and restores any removed ")"
Join(Array("=MySampleUDF"), ",") & "" = "=MySampleUDF"
Join(Array(277.193, 1000, 198), ",") & ")" = "277.193,1000,198)"
Finally, it Joins the Functions back together
Join(Array("=MySampleUDF", "277.193,1000,198)"), "(") = "=MySampleUDF(277.193,1000,198)"
Here is a subroutine that takes the selected cell and parses out the arguments of the any function, then evaluates each one and re-composes the formula definition.
For example the selected cell has =SUM(1+2+3,10) as formula.
After calling the sub the cell has =SUM(6,10) as formula
Public Sub EvalParams()
Dim r As Range
For Each r In Selection
Dim f As String
f = r.Formula
If Left(f, 1) = "=" Then
Dim i_open As Long
i_open = InStr(2, f, "(")
Dim id As String
' Get UDF name
id = Mid(f, 2, i_open - 2)
Dim i_close As Long
i_close = InStr(i_open + 1, f, ")")
Dim args() As String
' Seperate arguments by comma
args = VBA.Split(Mid(f, i_open + 1, i_close - i_open - 1), ",")
Dim i As Long
' Evaluate each argument separately
For i = 0 To UBound(args)
args(i) = CStr(Evaluate(args(i)))
Next i
' Compose formula again
f = "=" & id & "(" & VBA.Join(args, ",") & ")"
r.Formula = f
End If
Next r
End Sub
NOTE: This will fail if you have multiple function calls in the formula, like
=SUM(1,2,3) + SUM(4,5)

Deleting everything after the second occurrence of a number

Quick question, if I want to delete everything after the second occurrence of a number:
i.e -
I have:
1105 Bracket Ave. Suite 531 Touche
5201 Used St. 1351 Bored Today
I want:
1105 Bracket Ave. Suite 531
5201 Used St. 1351
is there a simple formula or VBA I would use for this?
Here is a UDF using VBA's regular expression engine to remove all after the second integer.
Option Explicit
Function FirstTwoNumbers(S As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "(\d+\D+\d+).*"
FirstTwoNumbers = .Replace(S, "$1")
End With
End Function
If there is only a single integer, it will return the entire string.
If the numbers might be decimal numbers, will need to modify .Pattern
And here is another UDF using only native VBA methods:
Function FirstTwo(S As String) As String
Dim V
Dim tS As String
Dim I As Long, numNumbers As Long
V = Split(S)
Do Until numNumbers = 2
tS = tS & Space(1) & V(I)
I = I + 1
If IsNumeric(V(I - 1)) Then numNumbers = numNumbers + 1
Loop
FirstTwo = Mid(tS, 2)
End Function
and finally, a formula with no particular assumptions:
=LEFT(A1,FIND(CHAR(1),SUBSTITUTE(A1," ",CHAR(1),LOOKUP(2,1/ISNUMBER(-TRIM(MID(SUBSTITUTE(A1," ",REPT(" ",99)),seq_99,99))),seq))))
seq and seq99 are Named Formulas Formula ► Define Name
seq Refers to: =ROW(INDEX($1:$255,1,1):INDEX($1:$255,255,1))
seq_99 Refers to: =IF(ROW(INDEX($1:$255,1,1):INDEX($1:$255,255,1))=1,1,(ROW(INDEX($1:$255,1,1):INDEX($1:$255,255,1))-1)*99)
This solution is with these assumptions:-
First occurrence of a number will not have a length > 10
There will atleast a distance of 10 or 10 alphabets including spaces between first and second number
There will always be a 'space' existing after second number
There will always be a second number present in the string
Try this:-
=TRIM(MID(A1,1,FIND(" ",A1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},A1&"0123456789",MIN(FIND({0,1,2,3,4,5,6,7,8,9},A1&"0123456789"))+10)))))
Here is a VBA approach, amend range to suit. It puts the answer in the adjacent column
Sub x()
Dim oMatches As Object, r As Range
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
For Each r In Range("A1:A5")
If .Test(r) Then
Set oMatches = .Execute(r)
If oMatches.Count > 1 Then
r.Offset(, 1).Value = Left(r, oMatches(1).firstindex + oMatches(1).Length)
Else
r.Offset(, 1).Value = r.Value
End If
Else
r.Offset(, 1).Value = r.Value
End If
Next r
End With
End Sub
You can use the following formula,if A1 is your string,in B1 write:
=LEFT(A1,MAX(IFERROR(ISNUMBER(VALUE(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)))*ROW(INDIRECT("1:"&LEN(A1))),0)))
press Ctrl+Shift+Enter at the same time Array Formula
This will read the length of the string and return the Maximum place of numbers (last number in the string) and return the Left() string till this number

IF two cells have at least one common word, true, else false: Excel formula

I have have two columns populated with text. I want to compare row-wise for any identical words between the two cells. How can this be accomplished with an Excel formula or vba function?
Best regards,
Try the following UDF():
Public Function Kompare(s1 As String, s2 As String) As Boolean
ary = Split(s1, " ")
bry = Split(s2, " ")
Kompare = False
For Each a In ary
For Each b In bry
If a = b Then
Kompare = True
Exit Function
End If
Next b
Next a
End Function
A third column would be needed. IE:
A..........B..........C
Text,1,another...Text,2,another......'=CommonWords(A1,B1,",") (Result another,Text)
In order to be able to use the UDF paste the following:
Function CommonWords(Text1 As Variant, Text2 As Variant, Character As Variant)
Dim ArrayText1 As Variant: ArrayText1 = Split(Text1, Character)
Dim ItemArrayText1 As Variant
Dim ArrayText2 As Variant: ArrayText2 = Split(Text2, Character)
Dim ItemArrayText2 As Variant
Dim SummaryCommonWords As Variant
For Each ItemArrayText1 In ArrayText1
If InStr(Text2, ItemArrayText1) > 0 And InStr(SummaryCommonWords, ItemArrayText1) = 0 Then SummaryCommonWords = IIf(SummaryCommonWords = "", ItemArrayText1, ItemArrayText1 & Character & SummaryCommonWords)
Next ItemArrayText1
For Each ItemArrayText2 In ArrayText2
If InStr(Text1, ItemArrayText2) > 0 And InStr(SummaryCommonWords, ItemArrayText2) = 0 Then SummaryCommonWords = IIf(SummaryCommonWords = "", ItemArrayText2, ItemArrayText2 & Character & SummaryCommonWords)
Next ItemArrayText2
CommonWords = IIf(CStr(SummaryCommonWords) <> "", SummaryCommonWords, "No common words!")
End Function
As an OT:
Wouldn't be better to know which words are repeated to analyze instead of a true, false statement?
You would need to work it to ignore spaces in the words, caps if needed.

VBA - Find certain strings in a worksheet

I want to create either a macro or a UDF that can find cells in an excel worksheet that contains the following:
POxxx
PO xxxxxxx
PO# xxxxx
PO#xxxx
(With x being numbers)
The string could be at the start or the middle of cells.
In addition, the function/macro should not find cells that contain entries like CORPORATE, where PO is part of a word.
All the cells that contains qualifying data, should be highlighted.
This small UDF will return 1 is the match is present, otherwise 0
Public Function IsItThere(r As Range) As Long
Dim st As String
st = "0,1,2,3,4,5,6,7,8,9"
ary = Split(st, ",")
st = r.Text
IsItThere = 1
For Each a In ary
If InStr(1, st, "PO" & a) > 1 Then Exit Function
If InStr(1, st, "PO " & a) > 1 Then Exit Function
If InStr(1, st, "PO#" & a) > 1 Then Exit Function
If InStr(1, st, "PO# " & a) > 1 Then Exit Function
Next a
IsItThere = 0
End Function
You could also use Regular Expressions to find the pattern.
Try this:
Sub Tester()
Dim c As Range
For Each c In Selection.Cells
c.Interior.Color = IIf(RegexpTest(c.Value), vbRed, vbGreen)
Next c
End Sub
Function RegexpTest(v As String)
Static re As Object 'note static: you must reset the VB environment
' (press the "stop" button) if you edit the
' Pattern below
If re Is Nothing Then
Set re = CreateObject("VBScript.RegExp")
'"PO" then optional #, optional space, then 2-5 digits
re.Pattern = "PO#?\s?\d{2,5}"
re.ignorecase = True
End If
RegexpTest = re.test(v)
End Function

Resources