Highlight Rows Based on the Sum of Multiple Cells

Captain_Conman

Board Regular
Joined
Jun 14, 2018
Messages
54
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 OrderAmountClass
Store 1513
A015130005080

<tbody>
</tbody>
12.43Debit Memo
Store 1513
A014460005574

<tbody>
</tbody>
7.14Debit Memo
Store 1513A014460005574(7.14)Credit Memo
Store 1583
A015950005582

<tbody>
</tbody>
(78.67)Credit Memo
Store 1583
A015970001912

<tbody>
</tbody>
19.44Debit Memo

<tbody>
</tbody>



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

Store #Purchase OrderAmountClass
Store 1513
A015130005080

<tbody>
</tbody>
12.43Debit Memo
Store 1513
A014460005574

<tbody>
</tbody>
7.14Debit Memo
Store 1541
A015130004085

<tbody>
</tbody>
(25.42)Credit Memo
Store 1541
A015130004085

<tbody>
</tbody>
(25.42)Credit Memo
Store 1541
A015130004085

<tbody>
</tbody>
42.37Debit Memo
Store 1541
A015130004085

<tbody>
</tbody>
50.82Debit Memo
Store 1541
A014340077651

<tbody>
</tbody>
96.75Debit Memo
Store 1583
A015950005582

<tbody>
</tbody>
(78.67)Credit Memo
Store 1583
A015970001912

<tbody>
</tbody>
19.44Debit Memo

<tbody>
</tbody>

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.
 
Last edited:

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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

Board Regular
Joined
Jun 14, 2018
Messages
54
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))
 
Last edited:

Captain_Conman

Board Regular
Joined
Jun 14, 2018
Messages
54
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

Board Regular
Joined
Jun 14, 2018
Messages
54
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

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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

Board Regular
Joined
Jun 14, 2018
Messages
54
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

Board Regular
Joined
Jun 14, 2018
Messages
54
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

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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
 
Last edited:

Forum statistics

Threads
1,081,845
Messages
5,361,663
Members
400,643
Latest member
RockStar89

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top