Macro required

D

Damo10

Active Member
Joined
Dec 13, 2010
Messages
460
Hi,

I have a workbook that I have created that imports data from 4 other workbooks and lists the data on the "Data" sheet, what I would like to have is a macro that will look through all the rows on this sheet and if it finds matches of data in 4 columns then have a message box pop up asking if the match would like to be comnined, if yes then the values for the matching rows in columns G & K be added together and entered into the first matching row and then the other matching rows deleted, the macro would then need to check if there are any other matches as there may be more than 1

See example of before and after

Excel Workbook
BCDEFGHIJK
1MachineIndexStartCustomerFillerAmmountCode%No Bags
214100:00Fredfudge100fu11010
314200:50Billcream200cr11020
414502:10Ellencream250cr11025
534800:00Bobfruit50fr12010
6341506:00Davemix300mx12060
7341807:00Edchocolate200ch1510
8342008:00Willchocolate500ch1525
Sheet1
Excel Workbook
BCDEFGHIJK
1MachineIndexStartCustomerFillerAmmountCode%No Bags
214100:00Fredfudge100fu11010
314200:50Billcream450cr11045
434800:00Bobfruit50fr12010
5341506:00Davemix300mx12060
6341807:00Edchocolate700ch1535
Excel 2010 Sheet2
Excel 2010
 
Sort by date Sort by votes
If you've added the line as described , then the word "Combined" will still be visible after the combining of the data has taken place, if you do it the other way the word "Combined will be deleted when combining takes place, or do you mean something else ???
Ref the colouring:- Do you mean colour each set in a different colour. The trouble with this is there are not many colours you can use that are light enough to not obscure the data, and you would either run out of colours or have to repeat. It might be better to give each set of data for combining a unique number say in column "A" or "B" so you would see immediately what the matches where.
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Hi Mick,

I see what you mean about the colours so your suggestion about giving each set a unique number in column A would be a good idea.

Regards
 
Upvote 0
You were right about the "Combined", the other 2 Codes should have been round the other way !!!
Try this:-
NB:- The Unique Numbers are named after the Code Name
Code: 
[COLOR=navy]Sub[/COLOR] CombineCluster()
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] nRng    [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Tri     [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Q       [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] k
[COLOR=navy]Dim[/COLOR] Rw      [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] Txt     [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] ray(1 To 4)
[COLOR=navy]Dim[/COLOR] fd [COLOR=navy]As[/COLOR] Boolean
[COLOR=navy]Dim[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Del [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Title [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] colRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] ColRng2 [COLOR=navy]As[/COLOR] Range
[COLOR=navy]With[/COLOR] Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
[COLOR=navy]End[/COLOR] With
[COLOR=navy]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & Rows.Count).End(xlUp))
Rng.Interior.ColorIndex = xlNone
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        Tri = Dn & Dn.Offset(, 1)
        [COLOR=navy]If[/COLOR] Dn.Offset(, 12) = 4 And Not UCase(Dn.Offset(, -1)) = "N" [COLOR=navy]Then[/COLOR]
        [COLOR=navy]If[/COLOR] Not .Exists(Tri) [COLOR=navy]Then[/COLOR]
 
             [COLOR=navy]Set[/COLOR] ray(Dn.Offset(, 11)) = Dn
                .Add Tri, ray
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR=navy]Set[/COLOR] Q(Dn.Offset(, 11)) = Dn
           .Item(Tri) = Q
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] .Keys
    [COLOR=navy]For[/COLOR] n = 1 To UBound(ray)
        [COLOR=navy]If[/COLOR] IsEmpty(.Item(k)(n)) [COLOR=navy]Then[/COLOR]
            fd = True
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] n
[COLOR=navy]If[/COLOR] fd = False [COLOR=navy]Then[/COLOR]
    [COLOR=navy]If[/COLOR] .Item(k)(1).Offset(, 7) = .Item(k)(2).Offset(, 7) And _
        .Item(k)(1).Offset(, 8) = .Item(k)(2).Offset(, 8) And _
            .Item(k)(3).Offset(, 7) = .Item(k)(4).Offset(, 7) And _
                .Item(k)(3).Offset(, 8) = .Item(k)(4).Offset(, 8) [COLOR=navy]Then[/COLOR]
      [COLOR=navy]If[/COLOR] Range("A1").Interior.ColorIndex = xlNone [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                  [COLOR=navy]Set[/COLOR] colRng = Union(.Item(k)(2), .Item(k)(4))
              [COLOR=navy]Else[/COLOR]
                   [COLOR=navy]Set[/COLOR] colRng = Union(colRng, .Item(k)(2), .Item(k)(4))
             [COLOR=navy]End[/COLOR] If
            [COLOR=navy]If[/COLOR] ColRng2 [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                  [COLOR=navy]Set[/COLOR] ColRng2 = Union(.Item(k)(1), .Item(k)(3))
              [COLOR=navy]Else[/COLOR]
                   [COLOR=navy]Set[/COLOR] ColRng2 = Union(ColRng2, .Item(k)(1), .Item(k)(3))
             [COLOR=navy]End[/COLOR] If
 
    [COLOR=navy]ElseIf[/COLOR] Range("A1").Interior.ColorIndex = 6 [COLOR=navy]Then[/COLOR]
      .Item(k)(1).Offset(, 5) = .Item(k)(1).Offset(, 5) + .Item(k)(2).Offset(, 5)
         .Item(k)(3).Offset(, 5) = .Item(k)(3).Offset(, 5) + .Item(k)(4).Offset(, 5)
            .Item(k)(1).Offset(, 9) = .Item(k)(1).Offset(, 9) + .Item(k)(2).Offset(, 9)
                .Item(k)(3).Offset(, 9) = .Item(k)(3).Offset(, 9) + .Item(k)(4).Offset(, 9)
 
              [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                  [COLOR=navy]Set[/COLOR] nRng = Union(.Item(k)(2), .Item(k)(4))
              [COLOR=navy]Else[/COLOR]
                   [COLOR=navy]Set[/COLOR] nRng = Union(nRng, .Item(k)(2), .Item(k)(4))
             [COLOR=navy]End[/COLOR] If
      [COLOR=navy]End[/COLOR] If
   [COLOR=navy]End[/COLOR] If
 [COLOR=navy]End[/COLOR] If
 fd = False
 [COLOR=navy]Next[/COLOR] k
[COLOR=navy]Dim[/COLOR] num
[COLOR=navy]If[/COLOR] Not colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
        [COLOR=navy]For[/COLOR] n = 1 To colRng.Areas.Count
            colRng.Areas(n).Offset(, -2) = "Com/Clus " & n
            ColRng2.Areas(n).Offset(, -2) = "Com/Clus " & n
        [COLOR=navy]Next[/COLOR] n
    colRng.Interior.ColorIndex = 36
    Range("A1").Interior.ColorIndex = 6
[COLOR=navy]ElseIf[/COLOR] colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    Range("A1").Interior.ColorIndex = xlNone
[COLOR=navy]End[/COLOR] If
[COLOR=navy]If[/COLOR] Not ColRng2 [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    ColRng2.Interior.ColorIndex = 6
    ColRng2.Offset(, -1) = "Combined"
[COLOR=navy]End[/COLOR] If
[COLOR=navy]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
   Range("A1").Interior.ColorIndex = xlNone
   nRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
[COLOR=navy]End[/COLOR] With
[COLOR=navy]Set[/COLOR] Rng = Nothing
[COLOR=navy]Set[/COLOR] nRng = Nothing
[COLOR=navy]Set[/COLOR] colRng = Nothing
[COLOR=navy]Set[/COLOR] ColRng2 = Nothing
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Code: 
[COLOR=navy]Sub[/COLOR] CombineRest()
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] nRng    [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Tri     [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Q       [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] k
[COLOR=navy]Dim[/COLOR] Rw [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] nnRng   [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] colRng  [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] ColRng2 [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n       [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]With[/COLOR] Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
[COLOR=navy]End[/COLOR] With
[COLOR=navy]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & 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
      [COLOR=navy]If[/COLOR] Not UCase(Dn.Offset(, -1)) = "N" [COLOR=navy]Then[/COLOR]
        Tri = Dn & Dn(, 5) & Dn(, 8) & Dn(, 9)
        [COLOR=navy]If[/COLOR] Not .Exists(Tri) [COLOR=navy]Then[/COLOR]
            .Add Tri, Array(Dn, nRng)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR=navy]If[/COLOR] Q(1) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] Q(1) = Dn
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            [COLOR=navy]End[/COLOR] If
            .Item(Tri) = Q
       [COLOR=navy]End[/COLOR] If
  [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] .Keys
    [COLOR=navy]If[/COLOR] Not .Item(k)(1) [COLOR=navy]Is[/COLOR] Nothing And .Item(k)(0).Offset(, 12) <= 1 [COLOR=navy]Then[/COLOR]
    [COLOR=navy]If[/COLOR] Range("A2").Interior.ColorIndex = xlNone [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] colRng = .Item(k)(1)
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] colRng = Union(colRng, .Item(k)(1))
            [COLOR=navy]End[/COLOR] If
            [COLOR=navy]If[/COLOR] ColRng2 [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] ColRng2 = .Item(k)(0)
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] ColRng2 = Union(ColRng2, .Item(k)(0))
            [COLOR=navy]End[/COLOR] If
   [COLOR=navy]ElseIf[/COLOR] Range("A2").Interior.ColorIndex = 6 [COLOR=navy]Then[/COLOR]
     .Item(k)(0).Offset(, 5) = .Item(k)(0).Offset(, 5) + Application.Sum(.Item(k)(1).Offset(, 5))
        .Item(k)(0).Offset(, 9) = .Item(k)(0).Offset(, 9) + Application.Sum(.Item(k)(1).Offset(, 9))
        .Item(k)(0).Offset(, 14) = .Item(k)(0).Offset(, 14) + Application.Sum(.Item(k)(1).Offset(, 14))
              [COLOR=navy]If[/COLOR] nnRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                  [COLOR=navy]Set[/COLOR] nnRng = .Item(k)(1)
              [COLOR=navy]Else[/COLOR]
                   [COLOR=navy]Set[/COLOR] nnRng = Union(nnRng, .Item(k)(1))
             [COLOR=navy]End[/COLOR] If
      [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
 [COLOR=navy]Next[/COLOR] k
[COLOR=navy]If[/COLOR] Not colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
     [COLOR=navy]For[/COLOR] n = 1 To colRng.Areas.Count
            colRng.Areas(n).Offset(, -2) = "Com/Rest " & n
            ColRng2.Areas(n).Offset(, -2) = "Com/Rest " & n
        [COLOR=navy]Next[/COLOR] n
 
    colRng.Interior.ColorIndex = 35
    Range("A2").Interior.ColorIndex = 6
[COLOR=navy]ElseIf[/COLOR] colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    Range("A2").Interior.ColorIndex = xlNone
[COLOR=navy]End[/COLOR] If
[COLOR=navy]If[/COLOR] Not ColRng2 [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    ColRng2.Interior.ColorIndex = 4
    ColRng2.Offset(, -1) = "Combined"
[COLOR=navy]End[/COLOR] If
[COLOR=navy]If[/COLOR] Not nnRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
   Range("A2").Interior.ColorIndex = xlNone
   nnRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
[COLOR=navy]End[/COLOR] With
[COLOR=navy]Set[/COLOR] Rng = Nothing
[COLOR=navy]Set[/COLOR] nRng = Nothing
[COLOR=navy]Set[/COLOR] nnRng = Nothing
[COLOR=navy]Set[/COLOR] colRng = Nothing
[COLOR=navy]Set[/COLOR] ColRng2 = Nothing
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Code: 
[COLOR=navy]Sub[/COLOR] CombineClusterSets()
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n       [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Cols    [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] nRng    [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Q       [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] Dic     [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] Doc     [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] k
[COLOR=navy]Dim[/COLOR] Dup
[COLOR=navy]Dim[/COLOR] Tri     [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Frt     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] DelRng  [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] colRng  [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] ColRng2 [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] oCrits  [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & Rows.Count).End(xlUp))
    [COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        Cols = Dn.Offset(, 1)
            [COLOR=navy]If[/COLOR] Not UCase(Dn.Offset(, -1)) = "N" [COLOR=navy]Then[/COLOR]
 
            [COLOR=navy]If[/COLOR] Not Dic.Exists(Cols) [COLOR=navy]Then[/COLOR]
                Dic.Add Cols, Array(Dn, Dn, Dn.Offset(, 4), Dn.Offset(, 7), Dn.Offset(, 8))
            [COLOR=navy]Else[/COLOR]
                Q = Dic.Item(Cols)
                    [COLOR=navy]Set[/COLOR] Q(0) = Union(Q(0), Dn)
                    Q(1) = Q(1) & Dn
                    Q(2) = Q(2) & ", " & Dn.Offset(, 4)
                    Q(3) = Q(3) & ", " & Dn.Offset(, 7)
                    Q(4) = Q(4) & ", " & Dn.Offset(, 8)
                Dic.Item(Cols) = Q
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Set[/COLOR] Doc = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] Dic.Keys
            [COLOR=navy]If[/COLOR] Dic.Item(k)(0).Count >= 3 [COLOR=navy]Then[/COLOR]
               oCrits = Dic.Item(k)(1) & Dic.Item(k)(2) & Dic.Item(k)(3) & Dic.Item(k)(4)
               [COLOR=navy]If[/COLOR] Not Doc.Exists(oCrits) [COLOR=navy]Then[/COLOR]
                    Doc.Add oCrits, Dic.Item(k)
                [COLOR=navy]Else[/COLOR]
                    [COLOR=navy]If[/COLOR] Range("A3").Interior.ColorIndex = xlNone [COLOR=navy]Then[/COLOR]
                        [COLOR=navy]If[/COLOR] colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                            [COLOR=navy]Set[/COLOR] colRng = Doc.Item(oCrits)(0)
                        [COLOR=navy]Else[/COLOR]
                            [COLOR=navy]Set[/COLOR] colRng = Union(colRng, Doc.Item(oCrits)(0))
                        [COLOR=navy]End[/COLOR] If
                        [COLOR=navy]If[/COLOR] ColRng2 [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                            [COLOR=navy]Set[/COLOR] ColRng2 = Dic.Item(k)(0)
                        [COLOR=navy]Else[/COLOR]
                            [COLOR=navy]Set[/COLOR] ColRng2 = Union(ColRng2, Dic.Item(k)(0))
                        [COLOR=navy]End[/COLOR] If
                    [COLOR=navy]ElseIf[/COLOR] Range("A3").Interior.ColorIndex = 6 [COLOR=navy]Then[/COLOR]
                    Q = Doc.Item(oCrits)
                            [COLOR=navy]For[/COLOR] n = 1 To Q(0).Count
                                Q(0)(n, 6) = Q(0)(n, 6) + Dic.Item(k)(0)(n, 6)
                                Q(0)(n, 10) = Q(0)(n, 10) + Dic.Item(k)(0)(n, 10)
                            [COLOR=navy]Next[/COLOR] n
                        [COLOR=navy]If[/COLOR] DelRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                            [COLOR=navy]Set[/COLOR] DelRng = Dic.Item(k)(0)
                        [COLOR=navy]Else[/COLOR]
                            [COLOR=navy]Set[/COLOR] DelRng = Union(DelRng, Dic.Item(k)(0))
                        [COLOR=navy]End[/COLOR] If
 
              [COLOR=navy]End[/COLOR] If
        [COLOR=navy]End[/COLOR] If
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] k
'[COLOR=green][B]MsgBox colRng.Address[/B][/COLOR]
[COLOR=navy]If[/COLOR] Not colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
 [COLOR=navy]For[/COLOR] n = 1 To colRng.Areas.Count
             colRng.Areas(n).Offset(, -2) = "Com/Sets " & n
            ColRng2.Areas(n).Offset(, -2) = "Com/Sets " & n
        [COLOR=navy]Next[/COLOR] n
    colRng.Offset(, -1) = "Combined"
    colRng.Interior.ColorIndex = 8
    Range("A3").Interior.ColorIndex = 6
[COLOR=navy]ElseIf[/COLOR] colRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    Range("A3").Interior.ColorIndex = xlNone
[COLOR=navy]End[/COLOR] If
[COLOR=navy]If[/COLOR] Not ColRng2 [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] ColRng2.Interior.ColorIndex = 34
[COLOR=navy]If[/COLOR] Not DelRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
   Range("A3").Interior.ColorIndex = xlNone
   DelRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Appologies for not replying sooner, I have not been very well.

I have tested the code on different sets of data and all seems to working well, thanks so much for your help.

Kind regards Damian
 
Upvote 0
Hi Mick,

I have been testing the code you have written and it is working well, there is one little issue with the combinecluster code that when it numbers the matching sets all 4 tanks should have the same set number where the code is splitting it into 2

<TABLE style="WIDTH: 239pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=317><COLGROUP><COL style="WIDTH: 88pt; mso-width-source: userset; mso-width-alt: 4278" width=117><COL style="WIDTH: 83pt; mso-width-source: userset; mso-width-alt: 4022" width=110><COL style="WIDTH: 68pt; mso-width-source: userset; mso-width-alt: 3291" width=90><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; WIDTH: 88pt; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66 height=20 width=117>Cluster Set No 1</TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; WIDTH: 83pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66 width=110></TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: yellow; WIDTH: 68pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl69 width=90>32</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66 height=20>Cluster Set No 1</TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66></TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: #ffff99; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl68>32</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66 height=20>Cluster Set No 2</TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66></TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: yellow; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl69>32</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66 height=20>Cluster Set No 2</TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl66></TD><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: #ffff99; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl68>32</TD></TR></TBODY></TABLE>

Can this be ammended so that it would only show as 1 matching set, then the next set of 4 as set 2?

Could you also change on all the codes that as well as adding the values in offsets 5,9 & 14 could it also do the same with the text values in offsets 16-24 in there respective columns? Each column might have the same text in the cell to combine, if it could only combine unique text values that would be great if not thats fine?

<TABLE style="WIDTH: 68pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=91><COLGROUP><COL style="WIDTH: 68pt; mso-width-source: userset; mso-width-alt: 3328" width=91><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; WIDTH: 68pt; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20 width=91>Before Combine



</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20>PACK LAST</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20>PACK LAST</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20>HOT WASH</TD></TR></TBODY></TABLE>

<TABLE style="WIDTH: 184pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=245><COLGROUP><COL style="WIDTH: 184pt; mso-width-source: userset; mso-width-alt: 8960" width=245><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; WIDTH: 184pt; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20 width=245>After</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20>PACK LAST, PACK LAST, HOT WASH</TD></TR></TBODY></TABLE>

<TABLE style="WIDTH: 111pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=148><COLGROUP><COL style="WIDTH: 111pt; mso-width-source: userset; mso-width-alt: 5412" width=148><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; WIDTH: 111pt; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20 width=148>After (Unique)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e0dfe3; BORDER-LEFT: #e0dfe3; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e0dfe3; BORDER-RIGHT: #e0dfe3" class=xl67 height=20>PACK LAST, HOT WASH</TD></TR></TBODY></TABLE>

I really appreciate the help that you have given me with this, it has been fantastic :)

Regards

Damian
 
Upvote 0
Try this for the first First bit ( Numbers).
Code: 
[COLOR="Navy"]Sub[/COLOR] CombineCluster()
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] Rw      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Txt     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray(1 To 4)
[COLOR="Navy"]Dim[/COLOR] Fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Del [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Title [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] colRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] ColRng2 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]With[/COLOR] Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & Rows.Count).End(xlUp))
Rng.Interior.ColorIndex = xlNone
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        Tri = Dn & Dn.Offset(, 1)
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, 12) = 4 And Not UCase(Dn.Offset(, -1)) = "N" [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not .Exists(Tri) [COLOR="Navy"]Then[/COLOR]
            
             [COLOR="Navy"]Set[/COLOR] Ray(Dn.Offset(, 11)) = Dn
                .Add Tri, Ray
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR="Navy"]Set[/COLOR] Q(Dn.Offset(, 11)) = Dn
           .Item(Tri) = Q
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .Keys
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray)
        [COLOR="Navy"]If[/COLOR] IsEmpty(.Item(k)(n)) [COLOR="Navy"]Then[/COLOR]
            Fd = True
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]If[/COLOR] Fd = False [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] .Item(k)(1).Offset(, 7) = .Item(k)(2).Offset(, 7) And _
        .Item(k)(1).Offset(, 8) = .Item(k)(2).Offset(, 8) And _
            .Item(k)(3).Offset(, 7) = .Item(k)(4).Offset(, 7) And _
                .Item(k)(3).Offset(, 8) = .Item(k)(4).Offset(, 8) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oRng [COLOR="Navy"]As[/COLOR] Range
      [COLOR="Navy"]If[/COLOR] Range("A1").Interior.ColorIndex = xlNone [COLOR="Navy"]Then[/COLOR]
         [COLOR="Navy"]Set[/COLOR] oRng = Union(.Item(k)(1), .Item(k)(2), .Item(k)(3), .Item(k)(4))
           c = c + 1
           oRng.Offset(, -2) = "Com/Clus " & c
            [COLOR="Navy"]If[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] colRng = Union(.Item(k)(2), .Item(k)(4))
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] colRng = Union(colRng, .Item(k)(2), .Item(k)(4))
             [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] ColRng2 = Union(.Item(k)(1), .Item(k)(3))
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] ColRng2 = Union(ColRng2, .Item(k)(1), .Item(k)(3))
             [COLOR="Navy"]End[/COLOR] If
   
    [COLOR="Navy"]ElseIf[/COLOR] Range("A1").Interior.ColorIndex = 6 [COLOR="Navy"]Then[/COLOR]
      .Item(k)(1).Offset(, 5) = .Item(k)(1).Offset(, 5) + .Item(k)(2).Offset(, 5)
         .Item(k)(3).Offset(, 5) = .Item(k)(3).Offset(, 5) + .Item(k)(4).Offset(, 5)
            .Item(k)(1).Offset(, 9) = .Item(k)(1).Offset(, 9) + .Item(k)(2).Offset(, 9)
                .Item(k)(3).Offset(, 9) = .Item(k)(3).Offset(, 9) + .Item(k)(4).Offset(, 9)
 
              [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] nRng = Union(.Item(k)(2), .Item(k)(4))
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, .Item(k)(2), .Item(k)(4))
             [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
 Fd = False
 [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] num
[COLOR="Navy"]If[/COLOR] Not colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
'[COLOR="Green"][B]        MsgBox colRng.Address[/B][/COLOR]
'[COLOR="Green"][B]        MsgBox ColRng2.Address[/B][/COLOR]
'[COLOR="Green"][B]        For n = 1 To colRng.Areas.Count[/B][/COLOR]
'[COLOR="Green"][B]            colRng.Areas(n).Offset(, -2) = "Com/Clus " & n[/B][/COLOR]
'[COLOR="Green"][B]            ColRng2.Areas(n).Offset(, -2) = "Com/Clus " & n[/B][/COLOR]
'[COLOR="Green"][B]        Next n[/B][/COLOR]
    colRng.Interior.ColorIndex = 36
    Range("A1").Interior.ColorIndex = 6
[COLOR="Navy"]ElseIf[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    Range("A1").Interior.ColorIndex = xlNone
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    ColRng2.Interior.ColorIndex = 6
    ColRng2.Offset(, -1) = "Combined"
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
   Range("A1").Interior.ColorIndex = xlNone
   nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Nothing
[COLOR="Navy"]Set[/COLOR] nRng = Nothing
[COLOR="Navy"]Set[/COLOR] colRng = Nothing
[COLOR="Navy"]Set[/COLOR] ColRng2 = Nothing
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Try these:-
Code: 
[COLOR="Navy"]Sub[/COLOR] CombineCluster()
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] Rw      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Txt     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray(1 To 4)
[COLOR="Navy"]Dim[/COLOR] Fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Del [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Title [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] colRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] ColRng2 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Tmix [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]With[/COLOR] Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & Rows.Count).End(xlUp))
Rng.Interior.ColorIndex = xlNone
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        Tri = Dn & Dn.Offset(, 1)
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, 12) = 4 And Not UCase(Dn.Offset(, -1)) = "N" [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not .Exists(Tri) [COLOR="Navy"]Then[/COLOR]
            
             [COLOR="Navy"]Set[/COLOR] Ray(Dn.Offset(, 11)) = Dn
                .Add Tri, Ray
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR="Navy"]Set[/COLOR] Q(Dn.Offset(, 11)) = Dn
           .Item(Tri) = Q
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .Keys
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray)
        [COLOR="Navy"]If[/COLOR] IsEmpty(.Item(k)(n)) [COLOR="Navy"]Then[/COLOR]
            Fd = True
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]If[/COLOR] Fd = False [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] .Item(k)(1).Offset(, 7) = .Item(k)(2).Offset(, 7) And _
        .Item(k)(1).Offset(, 8) = .Item(k)(2).Offset(, 8) And _
            .Item(k)(3).Offset(, 7) = .Item(k)(4).Offset(, 7) And _
                .Item(k)(3).Offset(, 8) = .Item(k)(4).Offset(, 8) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oRng [COLOR="Navy"]As[/COLOR] Range
      [COLOR="Navy"]If[/COLOR] Range("A1").Interior.ColorIndex = xlNone [COLOR="Navy"]Then[/COLOR]
         [COLOR="Navy"]Set[/COLOR] oRng = Union(.Item(k)(1), .Item(k)(2), .Item(k)(3), .Item(k)(4))
           c = c + 1
           oRng.Offset(, -2) = "Com/Clus " & c
            [COLOR="Navy"]If[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] colRng = Union(.Item(k)(2), .Item(k)(4))
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] colRng = Union(colRng, .Item(k)(2), .Item(k)(4))
             [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] ColRng2 = Union(.Item(k)(1), .Item(k)(3))
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] ColRng2 = Union(ColRng2, .Item(k)(1), .Item(k)(3))
             [COLOR="Navy"]End[/COLOR] If
   
    [COLOR="Navy"]ElseIf[/COLOR] Range("A1").Interior.ColorIndex = 6 [COLOR="Navy"]Then[/COLOR]
      .Item(k)(1).Offset(, 5) = .Item(k)(1).Offset(, 5) + .Item(k)(2).Offset(, 5)
    '[COLOR="Green"][B]''''''''''''''''[/B][/COLOR]
        [COLOR="Navy"]For[/COLOR] Tmix = 16 To 24
        [COLOR="Navy"]If[/COLOR] InStr(.Item(k)(1).Offset(, Tmix), .Item(k)(2).Offset(, Tmix)) = 0 [COLOR="Navy"]Then[/COLOR]
            .Item(k)(1).Offset(, Tmix) = .Item(k)(1).Offset(, Tmix) & ", " & .Item(k)(2).Offset(, Tmix)
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] InStr(.Item(k)(3).Offset(, Tmix), .Item(k)(4).Offset(, Tmix)) = 0 [COLOR="Navy"]Then[/COLOR]
            .Item(k)(3).Offset(, Tmix) = .Item(k)(3).Offset(, Tmix) & ", " & .Item(k)(4).Offset(, Tmix)
        [COLOR="Navy"]End[/COLOR] If
         [COLOR="Navy"]Next[/COLOR] Tmix
'[COLOR="Green"][B]''''''''''''''''''''''''''''[/B][/COLOR]
         .Item(k)(3).Offset(, 5) = .Item(k)(3).Offset(, 5) + .Item(k)(4).Offset(, 5)
           .Item(k)(1).Offset(, 9) = .Item(k)(1).Offset(, 9) + .Item(k)(2).Offset(, 9)
                .Item(k)(3).Offset(, 9) = .Item(k)(3).Offset(, 9) + .Item(k)(4).Offset(, 9)
 
              [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] nRng = Union(.Item(k)(2), .Item(k)(4))
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, .Item(k)(2), .Item(k)(4))
             [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
 Fd = False
 [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] num
[COLOR="Navy"]If[/COLOR] Not colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
'[COLOR="Green"][B]        MsgBox colRng.Address[/B][/COLOR]
'[COLOR="Green"][B]        MsgBox ColRng2.Address[/B][/COLOR]
'[COLOR="Green"][B]        For n = 1 To colRng.Areas.Count[/B][/COLOR]
'[COLOR="Green"][B]            colRng.Areas(n).Offset(, -2) = "Com/Clus " & n[/B][/COLOR]
'[COLOR="Green"][B]            ColRng2.Areas(n).Offset(, -2) = "Com/Clus " & n[/B][/COLOR]
'[COLOR="Green"][B]        Next n[/B][/COLOR]
    colRng.Interior.ColorIndex = 36
    Range("A1").Interior.ColorIndex = 6
[COLOR="Navy"]ElseIf[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    Range("A1").Interior.ColorIndex = xlNone
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    ColRng2.Interior.ColorIndex = 6
    ColRng2.Offset(, -1) = "Combined"
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
   Range("A1").Interior.ColorIndex = xlNone
   nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Nothing
[COLOR="Navy"]Set[/COLOR] nRng = Nothing
[COLOR="Navy"]Set[/COLOR] colRng = Nothing
[COLOR="Navy"]Set[/COLOR] ColRng2 = Nothing
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Code: 
[COLOR="Navy"]Sub[/COLOR] CombineRest()
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nnRng   [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] colRng  [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] ColRng2 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & 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
      [COLOR="Navy"]If[/COLOR] Not UCase(Dn.Offset(, -1)) = "N" [COLOR="Navy"]Then[/COLOR]
        Tri = Dn & Dn(, 5) & Dn(, 8) & Dn(, 9)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Tri) [COLOR="Navy"]Then[/COLOR]
            .Add Tri, Array(Dn, nRng)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR="Navy"]If[/COLOR] Q(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            [COLOR="Navy"]End[/COLOR] If
            .Item(Tri) = Q
       [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .Keys
    [COLOR="Navy"]If[/COLOR] Not .Item(k)(1) [COLOR="Navy"]Is[/COLOR] Nothing And .Item(k)(0).Offset(, 12) <= 1 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Range("A2").Interior.ColorIndex = xlNone [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] colRng = .Item(k)(1)
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] colRng = Union(colRng, .Item(k)(1))
            [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] ColRng2 = .Item(k)(0)
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] ColRng2 = Union(ColRng2, .Item(k)(0))
            [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]ElseIf[/COLOR] Range("A2").Interior.ColorIndex = 6 [COLOR="Navy"]Then[/COLOR]
     '[COLOR="Green"][B]''''''''''''''''[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] uRng [COLOR="Navy"]As[/COLOR] Range, Du [COLOR="Navy"]As[/COLOR] Range, uTxt
[COLOR="Navy"]For[/COLOR] Tmix = 16 To 24
  [COLOR="Navy"]Set[/COLOR] uRng = Union(.Item(k)(0).Offset(, Tmix), .Item(k)(1).Offset(, Tmix))
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Du [COLOR="Navy"]In[/COLOR] uRng
    [COLOR="Navy"]If[/COLOR] InStr(uTxt, Du) = 0 [COLOR="Navy"]Then[/COLOR]
        uTxt = uTxt & "," & Du
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] Du
 .Item(k)(0).Offset(, Tmix) = Mid(uTxt, 2)
 uTxt = ""
[COLOR="Navy"]Next[/COLOR] Tmix
        
'[COLOR="Green"][B]''''''''''''''''''''''''''''[/B][/COLOR]
     
     .Item(k)(0).Offset(, 5) = .Item(k)(0).Offset(, 5) + Application.Sum(.Item(k)(1).Offset(, 5))
        .Item(k)(0).Offset(, 9) = .Item(k)(0).Offset(, 9) + Application.Sum(.Item(k)(1).Offset(, 9))
        .Item(k)(0).Offset(, 14) = .Item(k)(0).Offset(, 14) + Application.Sum(.Item(k)(1).Offset(, 14))
              [COLOR="Navy"]If[/COLOR] nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] nnRng = .Item(k)(1)
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] nnRng = Union(nnRng, .Item(k)(1))
             [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]If[/COLOR] Not colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
     [COLOR="Navy"]For[/COLOR] n = 1 To colRng.Areas.Count
            colRng.Areas(n).Offset(, -2) = "Com/Rest " & n
            ColRng2.Areas(n).Offset(, -2) = "Com/Rest " & n
        [COLOR="Navy"]Next[/COLOR] n
    
    colRng.Interior.ColorIndex = 35
    Range("A2").Interior.ColorIndex = 6
[COLOR="Navy"]ElseIf[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    Range("A2").Interior.ColorIndex = xlNone
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    ColRng2.Interior.ColorIndex = 4
    ColRng2.Offset(, -1) = "Combined"
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
   Range("A2").Interior.ColorIndex = xlNone
   nnRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
[COLOR="Navy"]End[/COLOR] With
Rng.Offset(, 16).Resize(, 9).Columns.AutoFit
[COLOR="Navy"]Set[/COLOR] Rng = Nothing
[COLOR="Navy"]Set[/COLOR] nRng = Nothing
[COLOR="Navy"]Set[/COLOR] nnRng = Nothing
[COLOR="Navy"]Set[/COLOR] colRng = Nothing
[COLOR="Navy"]Set[/COLOR] ColRng2 = Nothing
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Code: 
[COLOR="Navy"]Sub[/COLOR] CombineClusterSets()
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Cols    [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic     [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Doc     [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] Dup
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Frt     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] DelRng  [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] colRng  [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] ColRng2 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oCrits  [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C7"), Range("C" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        Cols = Dn.Offset(, 1)
            [COLOR="Navy"]If[/COLOR] Not UCase(Dn.Offset(, -1)) = "N" [COLOR="Navy"]Then[/COLOR]
           
            [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Cols) [COLOR="Navy"]Then[/COLOR]
                Dic.Add Cols, Array(Dn, Dn, Dn.Offset(, 4), Dn.Offset(, 7), Dn.Offset(, 8))
            [COLOR="Navy"]Else[/COLOR]
                Q = Dic.Item(Cols)
                    [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
                    Q(1) = Q(1) & Dn
                    Q(2) = Q(2) & ", " & Dn.Offset(, 4)
                    Q(3) = Q(3) & ", " & Dn.Offset(, 7)
                    Q(4) = Q(4) & ", " & Dn.Offset(, 8)
                Dic.Item(Cols) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Doc = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
            [COLOR="Navy"]If[/COLOR] Dic.Item(k)(0).Count >= 3 [COLOR="Navy"]Then[/COLOR]
               oCrits = Dic.Item(k)(1) & Dic.Item(k)(2) & Dic.Item(k)(3) & Dic.Item(k)(4)
               [COLOR="Navy"]If[/COLOR] Not Doc.Exists(oCrits) [COLOR="Navy"]Then[/COLOR]
                    Doc.Add oCrits, Dic.Item(k)
                [COLOR="Navy"]Else[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Range("A3").Interior.ColorIndex = xlNone [COLOR="Navy"]Then[/COLOR]
                        [COLOR="Navy"]If[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                            [COLOR="Navy"]Set[/COLOR] colRng = Doc.Item(oCrits)(0)
                        [COLOR="Navy"]Else[/COLOR]
                            [COLOR="Navy"]Set[/COLOR] colRng = Union(colRng, Doc.Item(oCrits)(0))
                        [COLOR="Navy"]End[/COLOR] If
                        [COLOR="Navy"]If[/COLOR] ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                            [COLOR="Navy"]Set[/COLOR] ColRng2 = Dic.Item(k)(0)
                        [COLOR="Navy"]Else[/COLOR]
                            [COLOR="Navy"]Set[/COLOR] ColRng2 = Union(ColRng2, Dic.Item(k)(0))
                        [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]ElseIf[/COLOR] Range("A3").Interior.ColorIndex = 6 [COLOR="Navy"]Then[/COLOR]
                    Q = Doc.Item(oCrits)
                            
                 '[COLOR="Green"][B]''''''''''''''''''''''''''''''''''''''''''[/B][/COLOR]
   [COLOR="Navy"]Dim[/COLOR] Tmix [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] uRng [COLOR="Navy"]As[/COLOR] Range, Du [COLOR="Navy"]As[/COLOR] Range, uTxt
  [COLOR="Navy"]For[/COLOR] n = 1 To Q(0).Count
        [COLOR="Navy"]For[/COLOR] Tmix = 17 To 25
  [COLOR="Navy"]Set[/COLOR] uRng = Union(Q(0)(n, Tmix), Dic.Item(k)(0)(n, Tmix))
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Du [COLOR="Navy"]In[/COLOR] uRng
    [COLOR="Navy"]If[/COLOR] InStr(uTxt, Du) = 0 [COLOR="Navy"]Then[/COLOR]
        uTxt = uTxt & "," & Du
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] Du
 Q(0)(n, Tmix) = Mid(uTxt, 2)
 uTxt = ""
[COLOR="Navy"]Next[/COLOR] Tmix
                                
                  '[COLOR="Green"][B]'''''''''''''''''''''''''[/B][/COLOR]
                          Q(0)(n, 6) = Q(0)(n, 6) + Dic.Item(k)(0)(n, 6)
                          Q(0)(n, 10) = Q(0)(n, 10) + Dic.Item(k)(0)(n, 10)
                            [COLOR="Navy"]Next[/COLOR] n
                        [COLOR="Navy"]If[/COLOR] DelRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                            [COLOR="Navy"]Set[/COLOR] DelRng = Dic.Item(k)(0)
                        [COLOR="Navy"]Else[/COLOR]
                            [COLOR="Navy"]Set[/COLOR] DelRng = Union(DelRng, Dic.Item(k)(0))
                        [COLOR="Navy"]End[/COLOR] If
              
              [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] k
'[COLOR="Green"][B]MsgBox colRng.Address[/B][/COLOR]
[COLOR="Navy"]If[/COLOR] Not colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
 [COLOR="Navy"]For[/COLOR] n = 1 To colRng.Areas.Count
             colRng.Areas(n).Offset(, -2) = "Com/Sets " & n
            ColRng2.Areas(n).Offset(, -2) = "Com/Sets " & n
        [COLOR="Navy"]Next[/COLOR] n
    colRng.Offset(, -1) = "Combined"
    colRng.Interior.ColorIndex = 8
    Range("A3").Interior.ColorIndex = 6
[COLOR="Navy"]ElseIf[/COLOR] colRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    Range("A3").Interior.ColorIndex = xlNone
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not ColRng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] ColRng2.Interior.ColorIndex = 34
[COLOR="Navy"]If[/COLOR] Not DelRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
   Range("A3").Interior.ColorIndex = xlNone
   DelRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
Rng.Offset(, 16).Resize(, 9).Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Thanks for adding that part of the code it works great :)

The only thing that I have found with both cluster codes is that they do not combine offset colum 14 the same as the combine rest code soes, if you could ammend that then I think it will e perfect.

Thanks again for all you help it has been amazing

Regards Damian
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question Question
Looking for help or guidance on a potential Macro project
Replies
1
Views
90
Rijnsent
Rijnsent
F
  • Solved
Search & Find String of Words
2
Replies
10
Views
157
Peter_SSs
Peter_SSs
S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
419
STARL0RD
S
A
  • Solved
VBA code to extract a table
Replies
5
Views
289
Anthony47
A
D
  • Question Question
Modify a worksheet without registering it as a change
Replies
1
Views
110
Kaper
Kaper

Forum statistics

Threads
1,224,625
Messages
6,179,959
Members
452,950
Latest member
bwilliknits

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