Extracting two numbers from a cell then adding them together

Question

I am trying to work on a vba macro that would extract two numbers from a cell 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 and 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 likely 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

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

Answer 3

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:

1. Check if there is ; using SEARCH() . Use ISNUMBER() to handle the formula if it doesn't exist.
2. If there is ; then get the text between ;and # using MID() . Convert them to values using VALUE() and add them up.
3. 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 !

1. Replace every thing that is between ";"and "#" with "" using inbuit .Replace with wildcard "#*;"
2. Replace every thing that is after "#" with "" using wildcard "#*"
3. Remove all spaces
4. 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