Highlight Rows Based on the Sum of Multiple Cells

C

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.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Store #[/TD]
[TD]Purchase Order[/TD]
[TD]Amount[/TD]
[TD]Class[/TD]
[/TR]
[TR]
[TD]Store 1513[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015130005080[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]12.43[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1513[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A014460005574[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]7.14[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1513[/TD]
[TD]A014460005574[/TD]
[TD](7.14)[/TD]
[TD]Credit Memo[/TD]
[/TR]
[TR]
[TD]Store 1583[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015950005582[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD](78.67)[/TD]
[TD]Credit Memo[/TD]
[/TR]
[TR]
[TD]Store 1583[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015970001912[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]19.44[/TD]
[TD]Debit Memo[/TD]
[/TR]
</tbody>[/TABLE]



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

[TABLE="width: 500"]
<tbody>[TR]
[TD]Store #[/TD]
[TD]Purchase Order[/TD]
[TD]Amount[/TD]
[TD]Class[/TD]
[/TR]
[TR]
[TD]Store 1513[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015130005080[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]12.43[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1513[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A014460005574[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]7.14[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1541[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015130004085[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD](25.42)[/TD]
[TD]Credit Memo[/TD]
[/TR]
[TR]
[TD]Store 1541[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015130004085[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD](25.42)[/TD]
[TD]Credit Memo[/TD]
[/TR]
[TR]
[TD]Store 1541[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015130004085[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]42.37[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1541[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015130004085[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]50.82[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1541[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A014340077651[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]96.75[/TD]
[TD]Debit Memo[/TD]
[/TR]
[TR]
[TD]Store 1583[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015950005582[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD](78.67)[/TD]
[TD]Credit Memo[/TD]
[/TR]
[TR]
[TD]Store 1583[/TD]
[TD][TABLE="width: 260"]
<tbody>[TR]
[TD="width: 260"]A015970001912[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]19.44[/TD]
[TD]Debit Memo[/TD]
[/TR]
</tbody>[/TABLE]

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:

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
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
 
Upvote 0
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:
Upvote 0
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! :)
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
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:
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,755
Messages
6,180,776
Members
452,996
Latest member
nelsonsix66

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top