Extracting two numbers from a cell then adding them together - excel

Question

I am trying to work on a VBA macro that would extract two numbers from a cell and then add them together. The spreadsheet I am working on has a field like this:
Cell D1: .60 #2021-71; 0.90 #2021-71
I need to take the .60 and .90 out, add them together, and place them back in the cell.
For reference, there are other cells in this column that are like this:
Cell D2: .70 #2021-71
I have code that is already looking through the column and removing everything from the # sign on:
Dim tmp As String
For Each cell In Range("D:M")
If InStr(cell.Value, "#") > 0 Then
tmp = cell.Value
cell.Value = Left(tmp, InStr(tmp, "#") - 1)
End If
Is what I am trying to do even possible?

Answer 1

I've taken the approach of providing a custom function which you can then refer to on sheet.
You can call the function whatever you want...!
Public Function SumFirstNumbers(ByVal rngCell As Range) As Variant
Dim arrValues, i As Long, strValue As String, dblValue As String
If InStr(1, rngCell.Text, "#") > 0 Then
arrValues = Split(rngCell.Text, ";")
For i = 0 To UBound(arrValues)
dblValue = 0
strValue = Split(Trim(arrValues(i)), " ")(0)
If IsNumeric(strValue) Then dblValue = CDbl(strValue)
SumFirstNumbers = CDbl(SumFirstNumbers) + dblValue
Next
Else
SumFirstNumbers = rngCell.Value
End If
End Function
Then just use it like any other function in a cell...
This way, you can fill down and across and not have to worry about where the source data actually resides.
To then put it back in the original cells, just Copy → Paste Special → Values.
If it produces an incorrect result (before copying back to the original cells), the function can be changed and the data is still protected.
Naturally, this could still be incorporated into a wider macro if need be. You just need to apply it to your original code.
Dim tmp As String
For Each cell In Range("D:M")
If InStr(cell.Value, "#") > 0 Then
tmp = cell.Value
cell.Value = SumFirstNumbers(cell)
End If
Next
... something like that anyway.

Answer 2

Non VBA Method
Using formulas only. I have indented the formula (you can do that in the formula bar) for a better understanding.
=IFERROR(
IF(
ISNUMBER(SEARCH(";",D1)),
VALUE(MID(D1,SEARCH(";",D1)+1,SEARCH("#",D1,SEARCH(";",D1)+1)-SEARCH(";",D1)-1)) + VALUE(LEFT(D1,SEARCH("#",D1)-1)),
VALUE(LEFT(D1,SEARCH("#",D1)-1))
),0
)
Logic:
Check if there is ; using SEARCH(). Use ISNUMBER() to handle the formula if it doesn't exist.
If there is ; then get the text between ; and # using MID(). Convert them to values using VALUE() and add them up.
If there is no ; then just use LEFT() to get the number before #.
VBA Method
In case you are looking for VBA method to replace the values in the same column then here is a faster method using WildCards. If you have lots of data then in the end where I am using For Each aCell In rng, put the data in an array and loop the array instead.
Logic:
Make Excel do most of the Dirty work!
Replace every thing that is between ";" and "#" with "" using inbuit .Replace with wildcard "#*;"
Replace every thing that is after "#" with "" using wildcard "#*"
Remove all spaces
Use Evaluate.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
Dim lRow As Long
Set ws = Sheet1
With ws
With .Columns(4)
.Replace What:="#*;", Replacement:="+", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:="#*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End With
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set rng = .Range("D1:D" & lRow)
For Each aCell In rng
aCell.Value = .Evaluate(aCell.Value)
Next aCell
End With
End Sub
In Action

Answer 3

Replace by Numbers
Option Explicit
Sub ReplaceByNumbers()
Const Cols As String = "D:M"
Const FindDelimiter As String = "#"
Const SplitDelimiter As String = ";"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim rg As Range: Set rg = Intersect(ws.UsedRange, ws.Columns(Cols))
If rg Is Nothing Then Exit Sub ' no data
Dim rCount As Long: rCount = rg.Rows.Count
Dim cCount As Long: cCount = rg.Columns.Count
Dim Data As Variant
If rCount + cCount = 2 Then ' one cell only
ReDim Data(1 To 1, 1 To 1): Data(1, 1).Value = rg.Value
Else ' multiple cells
Data = rg.Value
End If
Dim SubStrings() As String
Dim r As Long, c As Long, n As Long
Dim iPos As Long
Dim Total As Double
Dim cString As String
Dim NumberFound As Boolean
For r = 1 To rCount
For c = 1 To cCount
cString = CStr(Data(r, c))
iPos = InStr(cString, FindDelimiter)
If iPos > 0 Then
SubStrings = Split(cString, SplitDelimiter)
For n = 0 To UBound(SubStrings)
If n > 0 Then
iPos = InStr(SubStrings(n), FindDelimiter)
End If
cString = Trim(Left(SubStrings(n), iPos - 1))
If Left(cString, 1) = "." Then cString = "0" & cValue
If IsNumeric(cString) Then
If NumberFound Then
Total = Total + CDbl(cString)
Else
Total = CDbl(cString)
NumberFound = True
End If
End If
Next n
If NumberFound Then
Data(r, c) = Total
NumberFound = False
End If
End If
Next c
Next r
rg.Value = Data
MsgBox "Replaced by numbers.", vbInformation, "ReplaceByNumbers"
End Sub