Parse and match opposite numbers in a cell

[TryingToLearn]

I'm trying to "consolidate" the values in a cell through vba. Over the course of a month, any number of entries can be made to this cell as a + or a -. End of month I'm just looking for the "leftover" values that don't have a matching opposite, so the following entry:

=$A$3+4105.38-4200+817.6+4200+79+204-204-4105.38-817.6-79+55+402+750-750+264.32-500+500-55-264.32-750+750-6500+6423+2105.98-2500+79+6500-402

would become:

=$A$3-55+6423+2105.98-2500+79

Since there can be any number of digits and/or decimal places and no pattern to the + or - signs, I'm stumped on how to parse a single amount to be able to compare it. Any suggestions to a direction would be appreciated.

 

[MickG]

This may do !!!
With your Formula in "A1", try this for Results in Msgbox and "A2".
NB:-The Code uses column "D" as helper column.

[COLOR=navy]Sub[/COLOR] MG26Apr21
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] txt [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] nstr [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant
nstr = Replace(Replace(Mid(Range("A1").Formula, 2), "+", ",+"), "-", ",-")
    Sp = Split(nstr, ",")
        Range("D1").Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
            [COLOR=navy]Set[/COLOR] Rng = Range(Range("D1"), Range("D" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
            txt = IIf(Dn.Value < 0, Mid(Dn.Value, 2), Dn.Value)
                [COLOR=navy]If[/COLOR] Not .Exists(txt) [COLOR=navy]Then[/COLOR]
                    .Add txt, Dn
                [COLOR=navy]Else[/COLOR]
                    [COLOR=navy]If[/COLOR] Dn.Value + .Item(txt) = 0 [COLOR=navy]Then[/COLOR]
                        Dn.Value = "": .Item(txt).Value = ""
                        .Remove (txt)
                    [COLOR=navy]End[/COLOR] If
                [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR]
[COLOR=navy]End[/COLOR] With
nstr = ""
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR=navy]Then[/COLOR]
        nstr = nstr & IIf(Not Left(Dn.Value, 1) = "-", "+" & Dn.Value, Dn.Value)
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
Rng.Delete
Range("A2").Formula = nstr
MsgBox nstr
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[TryingToLearn]

Sorry, posted too soon so please ignore last message!

This may do !!!
With your Formula in "A1", try this for Results in Msgbox and "A2".
NB:-The Code uses column "D" as helper column.
Regards Mick

Knew I couldn't do this on my abacus...

Mick this is just pure AWESOME! Changed slightly for my named ranges and the fact that the 1st entry was a 'fixed' range so actually needed "=" in front of it.

I learned that IIF is not a typo, a scripting dictionary can be used for comparisons.

I still need to learn how to use these new finds and not to wait so long before asking for help.

Thank you!

Sub parseOutstand() 'by Mick G [MENTION=3896]Mr Excel[/MENTION] 4-26-18
Dim Rng As Range
Dim AMn As Range
Dim n As Long
Dim txt As String
Dim nstr As String
Dim Sp As Variant
'Replace '+' & '-' with ',+' and ',-'
nstr = Replace(Replace(Mid(Range("Otstndng").Formula, 2), "+", ",+"), "-", ",-")
    'set Sp as all individual elements of cell entries split by ','
    Sp = split(nstr, ",")
        'in "helper" range, transpose entries from row to column
        Range("AM1").Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
            'Set Rng to all entries in col AM
            Set Rng = Range(Range("AM1"), Range("AM" & Rows.Count).End(xlUp))
            'Create a scripting dictionary
With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
        For Each AMn In Rng
            txt = IIf(AMn.Value < 0, Mid(AMn.Value, 2), AMn.Value)
                If Not .Exists(txt) Then
                    .Add txt, AMn
                Else
                    If AMn.Value + .item(txt) = 0 Then
                        AMn.Value = "": .item(txt).Value = ""
                        .Remove (txt)
                    End If
                End If
        Next
End With
nstr = ""
For Each AMn In Rng
    If Not IsEmpty(AMn.Value) Then
        If AMn.Value = "BOA" Then
            nstr = "=" & AMn.Value
        Else
            nstr = nstr & IIf(Not Left(AMn.Value, 1) = "-", "+" & AMn.Value, AMn.Value)
        End If
    End If
Next AMn
Rng.Delete
Range("OtstnAMng").Formula = nstr
MsgBox nstr
Stop
End Sub