asked on

Excel 2010 - Cell Value Addition & Transfer2

Hi experts/ Brad
Id like to make some adjustments (conditions) to the source code of the previous workbook please: https://www.experts-exchange.com/questions/28072893/Excel-2010-Cell-Value-Addition-Transfer.html
1. If there is no entry in col "D" then nothing is to be shown in col "E"
2. If there is only a text entry in col "D" then nothing is to be shown in col "E"
3. If there are 2 values in col "D" ie
porch 2.00L x 5.00W
alfresco 3.00L x 3.00W

then col "E" multiplies these 2 values, then adds the total of them so, the result would be 10.00 + 9.00 (the result of the porch + alfresco) = 19.00
4. I have found a problem where if i enter the following information;
Front: 10.56 m2
Rear Garage: 5.28 m2
Rear Pedestrian: 1.67 m2
The result should = 17.51, but instead = 23.51, please adjust code so that if there is an "m" followed by a number it does not add the value

byundt

In the earlier question, you were using / to indicate multiplication, and x was basically ignored. Your request 3 is contrary to that.

Except for that issue, you might consider:

Function AddItUp(s As String) As Variant
Dim RgExp As Object, oMatches As Object, oMatch As Object
Dim i As Long
Dim d1 As Double, dSum As Double
Set RgExp = CreateObject("VBScript.RegExp")
With RgExp
    .Global = True
    .Pattern = "((\d+)(\.?)(\d*)/)|((\d+)(\.?)(\d*))"    '"(/)?(/s*)(/d*)(/.)?(/d*)"
    s = Replace(s, "m2", "")
    s = Replace(s, "M2", "")
    Set oMatches = .Execute(s)
    i = oMatches.Count
    For Each oMatch In oMatches
        If InStr(1, oMatch, "/") > 0 Then
            d1 = Val(oMatch)
        Else
            If d1 <> 0 Then
                dSum = dSum + d1 * oMatch.Value
                d1 = 0
            Else
                dSum = dSum + oMatch.Value
            End If
        End If
    Next
End With
Set oMatch = Nothing
Set oMatches = Nothing
Set RgExp = Nothing
AddItUp = IIf(dSum <> 0, dSum, "")
End Function

Open in new window

Brad

byundt

I've added the ability to handle case 3.

Function AddItUp(s As String) As Variant
Dim RgExp As Object, oMatches As Object, oMatch As Object
Dim i As Long
Dim d1 As Double, dSum As Double
Set RgExp = CreateObject("VBScript.RegExp")
With RgExp
    .Global = True
    .Pattern = "((\d+)(\.?)(\d*)((/)|\s?([A-Za-z]{0,6}\s+x\s+)))|((\d+)(\.?)(\d*))"
    s = Replace(s, "m2", "")
    s = Replace(s, "M2", "")
    Set oMatches = .Execute(s)
    i = oMatches.Count
    For Each oMatch In oMatches
        If InStr(1, oMatch, "/") > 0 Then
            d1 = Val(oMatch)
        ElseIf Right(Trim(LCase(oMatch)), 1) = "x" Then
            d1 = Val(oMatch)
        Else
            If d1 <> 0 Then
                dSum = dSum + d1 * Val(oMatch)
                d1 = 0
            Else
                dSum = dSum + Val(oMatch)
            End If
        End If
    Next
End With
Set oMatch = Nothing
Set oMatches = Nothing
Set RgExp = Nothing
AddItUp = IIf(dSum <> 0, dSum, "")
End Function

Open in new window

Frank .S

ASKER

Thankyou Byundt, could you pls add to the worksheet and attach for me? I didnt save your original one and so i cant just copy and paste your new source code into the previous one.

ASKER CERTIFIED SOLUTION

byundt

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Frank .S

ASKER

Hi Byundt, for some reason Ive clicked onto the link thats been posted many times and nothing happens? I'll keep trying.

byundt

I just tested the link, and it is working for me.

Excel 2010 - Cell Value Addition &amp; Transfer2

Excel 2010 - Cell Value Addition & Transfer2