Highlight Rows Based on the Sum of Multiple Cells

Captain_Conman · Aug 3, 2018

Hello!

I currently have the following macro that highlights "offsets" in my spreadsheet.

Code:

Sub Offsets()


Dim Cell As Variant


For Each Cell In Range("B2:B2500")


Dim rng As Range
Set rng = Range(Cell, Cell.Offset(1, 0))


If Application.WorksheetFunction.CountIf(Range("B2:B2500"), Cell) > 1 Then
    If Cell.Offset(0, 1).Value = Cell.Offset(1, 1).Value * -1 Then
    rng.EntireRow.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    End If
    End If
Next


End Sub

For example, the following red transactions would be an offset.

Store #

Purchase Order

Amount

Class

Store 1513

A015130005080

12.43

Debit Memo

Store 1513

A014460005574

7.14

Debit Memo

Store 1513

A014460005574

(7.14)

Credit Memo

Store 1583

A015950005582

(78.67)

Credit Memo

Store 1583

A015970001912

19.44

Debit Memo

However, there are sometimes three or four lines that can offset each other as seen in red below.

Store #

Purchase Order

Amount

Class

Store 1513

A015130005080

12.43

Debit Memo

Store 1513

A014460005574

7.14

Debit Memo

Store 1541

A015130004085

(25.42)

Credit Memo

Store 1541

A015130004085

(25.42)

Credit Memo

Store 1541

A015130004085

42.37

Debit Memo

Store 1541

A015130004085

50.82

Debit Memo

Store 1541

A014340077651

96.75

Debit Memo

Store 1583

A015950005582

(78.67)

Credit Memo

Store 1583

A015970001912

19.44

Debit Memo

I am trying to write a macro that will look through matching POs and highlight multiple rows that sum to zero, as seen in the example above. I can't quite seem to figure this one out.

I hope this is clear, any advice is greatly appreciated.

MickG · Aug 4, 2018

Try this:-

Code:

[COLOR="Navy"]Sub[/COLOR] Match_Amounts()
'[COLOR="Green"][B]String Address/values Combinations Match[/B][/COLOR]
[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] K [COLOR="Navy"]As[/COLOR] Variant, L [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] G [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
Columns("A:D").Font.Color = vbBlack
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] rng
     L = "": G = ""
    [COLOR="Navy"]If[/COLOR] Dn.Offset(, 1).Value < 0 [COLOR="Navy"]Then[/COLOR]
         L = Dn.Offset(, 1).Address
    [COLOR="Navy"]Else[/COLOR]
         G = Dn.Offset(, 1).Address
    [COLOR="Navy"]End[/COLOR] If
    
    [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        
        .Add Dn.Value, Array(L, G)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
       [COLOR="Navy"]If[/COLOR] Not L = vbNullString [COLOR="Navy"]Then[/COLOR]
            Q(0) = Q(0) & IIf(Q(0) = "", L, "," & L)
       [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] Not G = vbNullString [COLOR="Navy"]Then[/COLOR]
            Q(1) = Q(1) & IIf(Q(1) = "", G, "," & G)
       [COLOR="Navy"]End[/COLOR] If
       .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] aMinus [COLOR="Navy"]As[/COLOR] Variant, aPlus [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, Rr [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Am [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ap [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
 [COLOR="Navy"]If[/COLOR] Not .Item(K)(0) = vbNullString And Not .Item(K)(1) = vbNullString [COLOR="Navy"]Then[/COLOR]
     [COLOR="Navy"]Set[/COLOR] R = Range(.Item(K)(0))
     aMinus = Application.Transpose(aComb(R))
     [COLOR="Navy"]Set[/COLOR] Rr = Range(.Item(K)(1))
     aPlus = Application.Transpose(aComb(Rr))
        [COLOR="Navy"]For[/COLOR] Ap = UBound(aPlus) To 1 [COLOR="Navy"]Step[/COLOR] -1
            [COLOR="Navy"]For[/COLOR] Am = UBound(aMinus) To 1 [COLOR="Navy"]Step[/COLOR] -1
                [COLOR="Navy"]If[/COLOR] Application.Sum(Range(aPlus(Ap))) + Application.Sum(Range(aMinus(Am))) = 0 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Not Range(aPlus(Ap)).Font.Color = vbRed And Not Range(aMinus(Am)).Font.Color = vbRed [COLOR="Navy"]Then[/COLOR]
                        Union(Range(aPlus(Ap)), Range(aMinus(Am))).EntireRow.Font.Color = vbRed
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Am
        [COLOR="Navy"]Next[/COLOR] Ap
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Function aComb(oNu [COLOR="Navy"]As[/COLOR] Range) [COLOR="Navy"]As[/COLOR] Variant
'[COLOR="Green"][B]combinations using Cell addresses[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] ray(), n, com, comgon, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oSt, oPc, iPc, obit, allnu, c, oVal(), res, oPst, oInt, Rr [COLOR="Navy"]As[/COLOR] Range, aBin [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]If[/COLOR] oNu.Count > 15 [COLOR="Navy"]Then[/COLOR] MsgBox "Number Range too Large (Max rows 15)": [COLOR="Navy"]Exit[/COLOR] Function
[COLOR="Navy"]For[/COLOR] n = 1 To oNu.Count
    aBin = aBin + Application.Combin(oNu.Count, n)
[COLOR="Navy"]Next[/COLOR] n
ReDim nRay(1 To aBin)
 n = 0
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] oNu
    n = n + 1
    comgon = comgon & IIf(comgon = "", Dn.Address, "," & Dn.Address)
    nRay(n) = Dn.Address
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]If[/COLOR] oNu.Count > 1 [COLOR="Navy"]Then[/COLOR]
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] oNu
   obit = Dn.Address
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rr [COLOR="Navy"]In[/COLOR] oNu
    [COLOR="Navy"]If[/COLOR] Rr.Row > Dn.Row [COLOR="Navy"]Then[/COLOR]
         allnu = obit & "," & Rr.Address
            c = c + 1
            ReDim Preserve oVal(c)
            oVal(c) = allnu
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Rr
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Do[/COLOR] Until allnu = comgon
res = res + 1
obit = oVal(res)
oSt = Split(obit, ",")(UBound(Split(obit, ",")))
  
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] oNu
        [COLOR="Navy"]If[/COLOR] Dn.Row > Range(oSt).Row [COLOR="Navy"]Then[/COLOR]
            allnu = obit & "," & Dn.Address
            c = c + 1
                [COLOR="Navy"]If[/COLOR] c = 65000 [COLOR="Navy"]Then[/COLOR] MsgBox "Rows on Limit of " & c: [COLOR="Navy"]Exit[/COLOR] Function
                    ReDim Preserve oVal(c)
                    oVal(c) = allnu
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Loop[/COLOR]

[COLOR="Navy"]For[/COLOR] oPst = 1 To UBound(oVal)
    nRay(oPst + oNu.Count) = oVal(oPst)
[COLOR="Navy"]Next[/COLOR] oPst
 [COLOR="Navy"]End[/COLOR] If
    aComb = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] Function

Regards Mick

Captain_Conman · Aug 6, 2018

Mick,

Thank you so much for your reply. I received a Run-time error '1004': Method 'Range' of object'_Global' failed on the line

Code:

Set R = Range(.Item(K)(0))

MickG · Aug 6, 2018

Can you post a copy of the data it failed on !!!

Captain_Conman · Aug 6, 2018

My apologizes.. It was my fault that it received an error! I tried again and it is pairing multiple rows perfectly! THANK YOU SO SO MUCH! This is going to be so helpful and I can't thank you enough!

Captain_Conman · Aug 6, 2018

Mick, If it is possible, could you help me make one minor adjustment? I previously mentioned that I would like the macro to "look through matching POs and highlight multiple rows that sum to zero". In it's current state it is doing that perfectly. However, if it is not too difficult, could we have the macro look through store numbers instead of POs? (Column A instead of B) I would try to do this myself, but this macro is a bit beyond my VBA knowledge and I don't want to mess anything up. Lol

Again, Thank you SOOOO much for all of your help on this. Please let me know if this adjustment is doable.

MickG · Aug 6, 2018

Try this Based on column "A" data and column "C" Values.

Code:

[COLOR="Navy"]Sub[/COLOR] MG06Aug38
'[COLOR="Green"][B]Code based on columns "A/C" Data[/B][/COLOR]
'[COLOR="Green"][B]String Address/values Combinations Match[/B][/COLOR]
[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] K [COLOR="Navy"]As[/COLOR] Variant, L [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] G [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
Columns("A:D").Font.Color = vbBlack
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] rng
     L = "": G = ""
    [COLOR="Navy"]If[/COLOR] Dn.Offset(, 2).Value < 0 [COLOR="Navy"]Then[/COLOR]
         L = Dn.Offset(, 2).Address
    [COLOR="Navy"]Else[/COLOR]
         G = Dn.Offset(, 2).Address
    [COLOR="Navy"]End[/COLOR] If
    
    [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        
        .Add Dn.Value, Array(L, G)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
       [COLOR="Navy"]If[/COLOR] Not L = vbNullString [COLOR="Navy"]Then[/COLOR]
            Q(0) = Q(0) & IIf(Q(0) = "", L, "," & L)
       [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] Not G = vbNullString [COLOR="Navy"]Then[/COLOR]
            Q(1) = Q(1) & IIf(Q(1) = "", G, "," & G)
       [COLOR="Navy"]End[/COLOR] If
       .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] aMinus [COLOR="Navy"]As[/COLOR] Variant, aPlus [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, Rr [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Am [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ap [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
 [COLOR="Navy"]If[/COLOR] Not .Item(K)(0) = vbNullString And Not .Item(K)(1) = vbNullString [COLOR="Navy"]Then[/COLOR]
     [COLOR="Navy"]Set[/COLOR] R = Range(.Item(K)(0))
     aMinus = Application.Transpose(aComb(R))
     [COLOR="Navy"]Set[/COLOR] Rr = Range(.Item(K)(1))
     aPlus = Application.Transpose(aComb(Rr))
        [COLOR="Navy"]For[/COLOR] Ap = UBound(aPlus) To 1 [COLOR="Navy"]Step[/COLOR] -1
            [COLOR="Navy"]For[/COLOR] Am = UBound(aMinus) To 1 [COLOR="Navy"]Step[/COLOR] -1
                [COLOR="Navy"]If[/COLOR] Application.Sum(Range(aPlus(Ap))) + Application.Sum(Range(aMinus(Am))) = 0 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Not Range(aPlus(Ap)).Font.Color = vbRed And Not Range(aMinus(Am)).Font.Color = vbRed [COLOR="Navy"]Then[/COLOR]
                        Union(Range(aPlus(Ap)), Range(aMinus(Am))).EntireRow.Font.Color = vbRed
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Am
        [COLOR="Navy"]Next[/COLOR] Ap
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]



Function aComb(oNu [COLOR="Navy"]As[/COLOR] Range) [COLOR="Navy"]As[/COLOR] Variant
'[COLOR="Green"][B]Combinations using Cell addresses[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] ray(), n, com, comgon, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oSt, oPc, iPc, obit, allnu, c, oVal(), res, oPst, oInt, Rr [COLOR="Navy"]As[/COLOR] Range, aBin [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]If[/COLOR] oNu.Count > 15 [COLOR="Navy"]Then[/COLOR] MsgBox "Number Range too Large (Max rows 15)": [COLOR="Navy"]Exit[/COLOR] Function
[COLOR="Navy"]For[/COLOR] n = 1 To oNu.Count
    aBin = aBin + Application.Combin(oNu.Count, n)
[COLOR="Navy"]Next[/COLOR] n

ReDim nRay(1 To aBin)
 n = 0
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] oNu
    n = n + 1
    comgon = comgon & IIf(comgon = "", Dn.Address, "," & Dn.Address)
    nRay(n) = Dn.Address
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]If[/COLOR] oNu.Count > 1 [COLOR="Navy"]Then[/COLOR]
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] oNu
   obit = Dn.Address
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rr [COLOR="Navy"]In[/COLOR] oNu
    [COLOR="Navy"]If[/COLOR] Rr.Row > Dn.Row [COLOR="Navy"]Then[/COLOR]
         allnu = obit & "," & Rr.Address
            c = c + 1
            ReDim Preserve oVal(c)
            oVal(c) = allnu
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Rr
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Do[/COLOR] Until allnu = comgon
res = res + 1
obit = oVal(res)
oSt = Split(obit, ",")(UBound(Split(obit, ",")))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] oNu
        [COLOR="Navy"]If[/COLOR] Dn.Row > Range(oSt).Row [COLOR="Navy"]Then[/COLOR]
            allnu = obit & "," & Dn.Address
            c = c + 1
                [COLOR="Navy"]If[/COLOR] c = 65000 [COLOR="Navy"]Then[/COLOR] MsgBox "Rows on Limit of " & c: [COLOR="Navy"]Exit[/COLOR] Function
                    ReDim Preserve oVal(c)
                    oVal(c) = allnu
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Loop[/COLOR]

[COLOR="Navy"]For[/COLOR] oPst = 1 To UBound(oVal)
    nRay(oPst + oNu.Count) = oVal(oPst)
[COLOR="Navy"]Next[/COLOR] oPst
 [COLOR="Navy"]End[/COLOR] If
    aComb = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] Function

Regards Mick

Captain_Conman · Aug 6, 2018

Okay,

So I ran the code this way and it is doing exactly what I need it too, which is AWESOME. However, Excel was not responding and eventually crashed. It also looks like it didn't make it the whole way down the sheet. I am not sure if this will work, but I published my workbook at this url...

https://docs.zoho.com/sheet/published.do?rid=8mn7ne44117aedba346c3bf05f712e04b3763

Maybe you can run it and see the same problems I am having. Hopefully this helps! Again, I cannot thank you enough for all you've done so far.

Captain_Conman · Aug 6, 2018

Now that I look deeper, I believe the problem may be with the 15 row Range limit. I have a few stores with transactions exceeding 40. I increased the limit to 50 and am still getting slow/unresponsive results. Any ideas?

MickG · Aug 7, 2018

The basic problem is that because there are so many repeats of the Unique items in column "A", that a particular item, results in a loop of 2000000 cycles, the code handles this but not the resulting effort to colour the related cells.
If you can allow column "A&B" data to be use as the Unique identifier, then try this code below !!!
This runs a lot faster because it reduces the Combinations

Code:

[COLOR=navy]Sub[/COLOR] MG07Aug48
'[COLOR=green][B]Code based on columns "A/B" Data (txt) and Column "C" as .items[/B][/COLOR]
'[COLOR=green][B]String Address/values Combinations Match[/B][/COLOR]
[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] K [COLOR=navy]As[/COLOR] Variant, L [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] G [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
Columns("A:D").Font.Color = vbBlack
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
  Txt = Dn.Value & Dn.Offset(, 1).Value
  [COLOR=navy]If[/COLOR] Txt <> "" [COLOR=navy]Then[/COLOR]
     L = "": G = ""
    [COLOR=navy]If[/COLOR] Dn.Offset(, 2).Value < 0 [COLOR=navy]Then[/COLOR]
         L = Dn.Offset(, 2).Address
    [COLOR=navy]Else[/COLOR]
         G = Dn.Offset(, 2).Address
    [COLOR=navy]End[/COLOR] If
    
    [COLOR=navy]If[/COLOR] Not .exists(Txt) [COLOR=navy]Then[/COLOR]
        
        .Add Txt, Array(L, G)
    [COLOR=navy]Else[/COLOR]
        Q = .Item(Txt)
       [COLOR=navy]If[/COLOR] Not L = vbNullString [COLOR=navy]Then[/COLOR]
            Q(0) = Q(0) & IIf(Q(0) = "", L, "," & L)
       [COLOR=navy]End[/COLOR] If
        [COLOR=navy]If[/COLOR] Not G = vbNullString [COLOR=navy]Then[/COLOR]
            Q(1) = Q(1) & IIf(Q(1) = "", G, "," & G)
       [COLOR=navy]End[/COLOR] If
       .Item(Txt) = Q
    [COLOR=navy]End[/COLOR] If
 [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] aMinus [COLOR=navy]As[/COLOR] Variant, aPlus [COLOR=navy]As[/COLOR] Variant, R [COLOR=navy]As[/COLOR] Range, Rr [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Am [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ap [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] nRng [COLOR=navy]As[/COLOR] Range
Application.ScreenUpdating = False
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
 
 [COLOR=navy]If[/COLOR] Not .Item(K)(0) = vbNullString And Not .Item(K)(1) = vbNullString [COLOR=navy]Then[/COLOR]
    
     [COLOR=navy]Set[/COLOR] R = Range(.Item(K)(0))
    '[COLOR=green][B] MsgBox R.Address[/B][/COLOR]
     aMinus = Application.Transpose(aComb(R))
     [COLOR=navy]Set[/COLOR] Rr = Range(.Item(K)(1))
     aPlus = Application.Transpose(aComb(Rr))

        
        [COLOR=navy]For[/COLOR] Ap = UBound(aPlus) To 1 [COLOR=navy]Step[/COLOR] -1
            [COLOR=navy]For[/COLOR] Am = UBound(aMinus) To 1 [COLOR=navy]Step[/COLOR] -1
               [COLOR=navy]Set[/COLOR] nRng = Nothing
               
                [COLOR=navy]If[/COLOR] Application.Sum(Range(aPlus(Ap))) + Application.Sum(Range(aMinus(Am))) = 0 [COLOR=navy]Then[/COLOR]
                    [COLOR=navy]If[/COLOR] Not Range(aPlus(Ap)).Font.Color = vbRed And Not Range(aMinus(Am)).Font.Color = vbRed [COLOR=navy]Then[/COLOR]
                       Union(Range(aPlus(Ap)), Range(aMinus(Am))).EntireRow.Font.Color = vbRed
                    [COLOR=navy]End[/COLOR] If
                [COLOR=navy]End[/COLOR] If
            [COLOR=navy]Next[/COLOR] Am
        [COLOR=navy]Next[/COLOR] Ap
 [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
MsgBox "Run"
'[COLOR=green][B]Application.ScreenUpdating = True[/B][/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Function aComb(oNu [COLOR=navy]As[/COLOR] Range) [COLOR=navy]As[/COLOR] Variant
'[COLOR=green][B]Combinations using Cell addresses[/B][/COLOR]
[COLOR=navy]Dim[/COLOR] ray(), n, com, comgon, Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] oSt, oPc, iPc, obit, allnu, c, oVal(), res, oPst, oInt, Rr [COLOR=navy]As[/COLOR] Range, aBin [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]If[/COLOR] oNu.Count > 15 [COLOR=navy]Then[/COLOR] MsgBox "Number Range too Large (Max rows 15)": [COLOR=navy]Exit[/COLOR] Function
[COLOR=navy]For[/COLOR] n = 1 To oNu.Count
    aBin = aBin + Application.Combin(oNu.Count, n)
[COLOR=navy]Next[/COLOR] n
ReDim nRay(1 To aBin)
 n = 0
 [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] oNu
    n = n + 1
    comgon = comgon & IIf(comgon = "", Dn.Address, "," & Dn.Address)
    nRay(n) = Dn.Address
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]If[/COLOR] oNu.Count > 1 [COLOR=navy]Then[/COLOR]
 [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] oNu
   obit = Dn.Address
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Rr [COLOR=navy]In[/COLOR] oNu
    [COLOR=navy]If[/COLOR] Rr.Row > Dn.Row [COLOR=navy]Then[/COLOR]
         allnu = obit & "," & Rr.Address
            c = c + 1
            ReDim Preserve oVal(c)
            oVal(c) = allnu
   [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Rr
[COLOR=navy]Next[/COLOR] Dn

[COLOR=navy]Do[/COLOR] Until allnu = comgon
res = res + 1
obit = oVal(res)
oSt = Split(obit, ",")(UBound(Split(obit, ",")))
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] oNu
        [COLOR=navy]If[/COLOR] Dn.Row > Range(oSt).Row [COLOR=navy]Then[/COLOR]
            allnu = obit & "," & Dn.Address
            c = c + 1
                [COLOR=navy]If[/COLOR] c = 65000 [COLOR=navy]Then[/COLOR] MsgBox "Rows on Limit of " & c: [COLOR=navy]Exit[/COLOR] Function
                    ReDim Preserve oVal(c)
                    oVal(c) = allnu
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Loop[/COLOR]

[COLOR=navy]For[/COLOR] oPst = 1 To UBound(oVal)
    nRay(oPst + oNu.Count) = oVal(oPst)
[COLOR=navy]Next[/COLOR] oPst
 [COLOR=navy]End[/COLOR] If
    aComb = Application.Transpose(nRay)
[COLOR=navy]End[/COLOR] Function

Regards Mick

Highlight Rows Based on the Sum of Multiple Cells

Captain_Conman

Board Regular

Excel Facts

MickG

MrExcel MVP

Captain_Conman

Board Regular

MickG

MrExcel MVP

Captain_Conman

Board Regular

Captain_Conman

Board Regular

MickG

MrExcel MVP

Captain_Conman

Board Regular

Captain_Conman

Board Regular

MickG

MrExcel MVP

Forum statistics

Share this page

Highlight Rows Based on the Sum of Multiple Cells

Board Regular

Excel Facts

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

Board Regular

MrExcel MVP

Board Regular

Board Regular

MrExcel MVP

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock