Range Grouping problem

P

pingme89

Board Regular
Joined
Jan 23, 2014
Messages
172
Office Version
  1. 365
Platform
  1. Windows
I have a spreadsheet with cell information on a worksheet.

For instance in Column A, I have have Cell name ("A1", "A2","A3" , "B21" ... etc)
In another column I have interior cell colors for each cell listed in Column A.

Instead of using:
ActiveSheet.Range("A1").interior.color = rgb(255,255,255)
ActiveSheet.Range("A2").interior.color = rgb(255,255,255)
ActiveSheet.Range("A3").interior.color = rgb(255,255,255)
ActiveSheet.Range("A4").interior.color = rgb(255,255,255)
ActiveSheet.Range("B2").interior.color = rgb(255,20,50)
ActiveSheet.Range("C2").interior.color = rgb(255,20,50)
ActiveSheet.Range("D2").interior.color = rgb(255,20,50)
ActiveSheet.Range("B3").interior.color = rgb(255,20,50)
ActiveSheet.Range("C3").interior.color = rgb(255,20,50)
ActiveSheet.Range("D3").interior.color = rgb(255,20,50)

I can't figure out how to sort the Interior colors in groupings. In my spreadsheet the Interior colors are listed in Column I with values like RGB(255,20,50).
I want to group cells in a string like "A1:A4" as in the above example all have the same interior color. And string grouped as "B2:D3".
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
There's no way to sort on the color without breaking out the values. Here's one way to do that:

Book1
ABCD
1ActiveSheet.Range("A1").interior.color = rgb(255,255,255)255255255
2ActiveSheet.Range("A2").interior.color = rgb(255,255,255)255255255
3ActiveSheet.Range("A3").interior.color = rgb(255,255,255)255255255
4ActiveSheet.Range("A4").interior.color = rgb(255,255,255)255255255
5ActiveSheet.Range("B2").interior.color = rgb(255,20,50)2552050
6ActiveSheet.Range("C2").interior.color = rgb(255,20,50)2552050
7ActiveSheet.Range("D2").interior.color = rgb(255,20,50)2552050
8ActiveSheet.Range("B3").interior.color = rgb(255,20,50)2552050
9ActiveSheet.Range("C3").interior.color = rgb(255,20,50)2552050
10ActiveSheet.Range("D3").interior.color = rgb(255,20,50)2552050
Sheet1
Cell Formulas
RangeFormula
B1:D10B1=TEXTSPLIT(SUBSTITUTE(RIGHT(A1,LEN(A1)-SEARCH("(",A1, SEARCH(")",A1) )),")",""),",")
Dynamic array formulas.


With that you can sort on columns C, or D. Note that those values are still text but you will be prompted to "Sort anything that looks like a number as a number" by default. Select that option:

1669051255296.png


It would be helpful if you go to your Account Details and specified what version of Excel you're using and on what platform. The above uses some of the newer functions that aren't available to versions earlier than 2021.

Hope it was worth the wait!
 
Upvote 0
Actually, that is not the sorting problem I was trying to achieve.

Given a list of single cell ranges such as B22, B23, C22, C23, A48, A49, A50, R26, S26, T26

I want to write an algorithm that would group adjacent cells together to be in the above example "B22:C23, A49:A50, R26:T26"
I have almost solved the problem, but my solution is very slow.

For each cell, I separate the Column Letter and Row Number. I then Convert the Column Letter to a the Column number.
I then loop through each range to see if they are adjacent or not by comparing the column numbers and Row numbers. When I have a column of ranges that number close to 1000 cell ranges, it takes a very long time calculate. I tried to reduce the loop count each time I merge cells, by for instance Merge B22:B23 then remove B22 and remove B23 from the list and add B22:B23 to the list. But it is problematic.

I loop through and merge all horizontally adjacent cells and once complete, I run another loop to merged all vertically adjacent ranges. For instance, B22:C22 and B23:C23 are then merged to become B22:C23, and B22:C22 and B23:C23 are then removed from the list. My solution was to create a function that takes a collection of Cell Ranges. I figured that using a collection in memory would create faster execution times. Again, my problem is speed. It can take hours for a list of 800 or so cell ranges. My loops may not be very efficient.
 
Upvote 0
I was able to get this to work using Power Query. The query requires 2 pairs of two cells to work. Your sample only had 5 pairs of cells (2 pairs of 2), so the last 2 cells (S26, T26) were dropped.

Book1
ABC
1Column1Ranges
2B22, B23, C22, C23, A48, A49, A50, R26, S26, T26B22:C23
3A48:R26
Sheet2


This is the M Code for the query:

Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    SplitColumnByPosition = Table.ExpandListColumn(Table.TransformColumns(Source, {{"Column1", Splitter.SplitTextByRepeatedLengths(10), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Column1"),
    SplitColumnByDelimiter = Table.SplitColumn(SplitColumnByPosition, "Column1", Splitter.SplitTextByEachDelimiter({","}, QuoteStyle.Csv, false), {"Start", "End"}),
    TrimmedText = Table.TransformColumns(SplitColumnByDelimiter,{{"Start", Text.Trim, type text}, {"End", Text.Trim, type text}}),
    ReplacedValue = Table.ReplaceValue(TrimmedText,",","",Replacer.ReplaceText,{"End"}),
    AddedIndex = Table.AddIndexColumn(ReplacedValue, "Index", 1, 1, Int64.Type),
    NumberOfRows = List.Max( AddedIndex[Index] ),
    InsertedModulo = Table.AddColumn(AddedIndex, "Modulo", each Number.Mod([Index], 2), type number),
    AddedRanges = Table.AddColumn(InsertedModulo, "Ranges", each if [Index] < NumberOfRows then [Start] & ":" & InsertedModulo[End]{[Index]} else null),
    ChangedType = Table.TransformColumnTypes(AddedRanges,{{"Ranges", type text}}),
    FilteredModulo = Table.SelectRows(ChangedType, each ([Modulo] = 1) and ([Ranges] <> null)),
    RemovedOtherColumns = Table.SelectColumns(FilteredModulo,{"Ranges"})
in
    RemovedOtherColumns

I have no doubt there's a way to get a LAMBDA function to do this as well, but I couldn't work it out (yet?!).
 
Upvote 0
All the cell ranges are single cell ranges to begin with. The initial Ranges are all single cell ranges and not paired so it doesn't work for me in this case. Ideally, I want to call a function and pass a Collection of Single ranges to the Function and return the grouped ranges. My code is quite long and although it seems to work, I may have overcomplicated it thus the run time being excessively long.
This is what I have. But any improvement would be greatly appreciated.

VBA Code: 
Private Function GroupCollectionRNG(ByRef RangeCollection As VBA.Collection)
Dim sheet As Worksheet
Dim MergeCount As Long

RangeCollectionCount = RangeCollection.Count


For i = 1 To RangeCollectionCount                   ' Separates Column Letter and Row number to sort by 2 columns
    RNGtoCompare = RangeCollection(i)
    ThisWorkbook.Worksheets("Unique Ranges").Range("A" & i).Value = RNGtoCompare
    ThisWorkbook.Worksheets("Unique Ranges").Range("B" & i).Value = Split(Columns(Range(RNGtoCompare).Column).Address(, False), ":")(1)
    ThisWorkbook.Worksheets("Unique Ranges").Range("C" & i).Value = Range(RNGtoCompare).Row
Next i
    
If RangeCollectionCount > 0 Then
    ThisWorkbook.Worksheets("Unique Ranges").Range("A1:C" & RangeCollectionCount).sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1"), Order1:=xlAscending, Header:=xlNo  ' Sorts by Column Letter and Row number
End If
' Empty collection
For x = 1 To RangeCollectionCount
    RangeCollection.Remove (1)
Next x
    
For i = 1 To RangeCollectionCount                      ' Read all Values into RangeCollection after sorting
        RNGvalue = ThisWorkbook.Worksheets("Unique Ranges").Range("A" & i).Value
        RangeCollection.Add RNGvalue
Next i
MergeCount = 0
ThisWorkbook.Worksheets("Unique Ranges").Range("A1:C10000").ClearContents
    
' Loop to compare previous Range Column and next Range Column to see to see if they are adjacent.  Remember this is done on same Row so comparison is only for horizontal comparison.
' If they are contiguous, join and compare next Range until the end of SameIntColor Collection. Once joined, remove from Collection and decrease K end of Loop
    
' BEGINNING of HORIZONTAL GROUPING
On Error Resume Next
For j = 1 To RangeCollectionCount - MergeCount  ' Loop to Set RNG to that rest of collection would compare to. This Loop only merges Horizontal Ranges together.
    If InStr(RangeCollection(j), ":") > 0 Or InStr(RNGtoCompare, ":") > 0 Then
        BaseRNGisMerged = True
    Else
        RNGtoCompare = RangeCollection(j)               ' Sets Value that rest of collection would compare to
        BaseRNGisMerged = False
    End If
        
    For k = 1 To RangeCollectionCount - MergeCount ' Loop of compare all Ranges in Collection
        If Not RNGtoCompare = RangeCollection(k) Then   ' This conditional statement ensures comparision to itself does not occur
            CurrentRNGValue = RangeCollection(k)
            If InStr(CurrentRNGValue, ":") > 0 Then
                LoopRNGisMerged = True
            Else
                LoopRNGisMerged = False
            End If
            If InStr(RNGtoCompare, ":") > 0 Then
                BaseRNGisMerged = True
            Else
                BaseRNGisMerged = False
            End If
            If BaseRNGisMerged = False And LoopRNGisMerged = False Then   ' Checks to see if Base and Current Range is a Merged Range *** FOR UNMERGED RANGES ***
                BaseLetter = Split(Columns(Range(RNGtoCompare).Column).Address(, False), ":")(1)
                BaseColNum = Range(BaseLetter & 1).Column
                BaseRow = Range(RNGtoCompare).Row
                    
                CurrentLetter = Split(Columns(Range(CurrentRNGValue).Column).Address(, False), ":")(1)
                CurrentColNum = Range(CurrentLetter & 1).Column
                CurrentRow = Range(CurrentRNGValue).Row

                If BaseRow = CurrentRow And BaseColNum + 1 = CurrentColNum Then                                 '***** CurrentCol is to the Right of Base Column *****
                    MergedRNG = BaseLetter & BaseRow & ":" & CurrentLetter & BaseRow
                    RangeCollection.Add MergedRNG
                    BaseRNGisMerged = True
                    MergeCount = MergeCount + 1
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare And Not IsNull(RangeCollection(x)) Then
                            CurrX = RangeCollection(x)
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                        End If
                    Next x
                    RangeCollectionCount = RangeCollection.Count - MergeCount
                    j = j - 1
                    k = RangeCollection.Count
                    Exit For
                            
                    ' NEED TO WORK ON CODE TO COMPARE ALL OTHER NON-MERGED VALUES WITH RECENTLY MERGED RANGE
        
                    ElseIf BaseRow = CurrentRow And BaseColNum - 1 = CurrentColNum Then                             '***** CurrentCol is to the Left of Base Column *****
                            MergedRNG = CurrentLetter & BaseRow & ":" & BaseLetter & BaseRow
                            BaseRNGisMerged = True
                            RangeCollection.Add MergedRNG
                            MergeCount = MergeCount + 1
                            LoopCount = 0
                            For x = 1 To RangeCollection.Count
                                If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                                    CurrX = RangeCollection(x)
                                    
                                    If RangeCollection(x) = CurrentRNGValue Then
                                        LoopCount = LoopCount + 1
                                    ElseIf RangeCollection(x) = RNGtoCompare Then
                                        LoopCount = LoopCount + 1
                                    End If
                                    RangeCollection.Remove (x)
                                    x = x - 1
                                    If LoopCount = 2 Then
                                        Exit For
                                    End If
                                End If
                            Next x
                            RNGtoCompare = RangeCollection(1)                         
                            RangeCollectionCount = RangeCollection.Count - MergeCount
                            k = RangeCollection.Count
                            j = j - 1
                            Exit For
                    End If
                    
                ElseIf BaseRNGisMerged = True And Len(RNGtoCompare) - Len(Replace(RNGtoCompare, "/", "")) = 0 And LoopRNGisMerged = False Then ' Base Range is Merged, Loop Range is NOT Merged
                    HyphenLoc = InStr(RNGtoCompare, ":")
                    FirstHalfBaseRNG = Left(RNGtoCompare, HyphenLoc - 1)
                    FirstHalfBaseLetter = Split(Columns(Range(FirstHalfBaseRNG).Column).Address(, False), ":")(1)
                    FirstHalfBaseColNum = Range(FirstHalfBaseLetter & 1).Column
                    SecondHalfBaseRNG = Right(RNGtoCompare, Len(RNGtoCompare) - HyphenLoc)
                    SecondHalfBaseLetter = Split(Columns(Range(SecondHalfBaseRNG).Column).Address(, False), ":")(1)
                    SecondHalfBaseColNum = Range(SecondHalfBaseLetter & 1).Column
                    BaseRow = Range(SecondHalfBaseRNG).Row
                
                    CurrentLetter = Split(Columns(Range(CurrentRNGValue).Column).Address(, False), ":")(1)
                    CurrentColNum = Range(CurrentLetter & 1).Column
                    CurrentRow = Range(CurrentRNGValue).Row
                    
                    If BaseRow = CurrentRow And SecondHalfBaseColNum + 1 = CurrentColNum Then                           '***** CurrentCol is to the Right of Base Column *****
                        MergedRNG = FirstHalfBaseLetter & BaseRow & ":" & CurrentLetter & BaseRow
                        BaseRNGisMerged = True
                        MergeCount = MergeCount + 1
                        LoopCount = 0
                        For x = 1 To RangeCollection.Count
                            If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                                CurrX = RangeCollection(x)
                                If RangeCollection(x) = CurrentRNGValue Then
                                    LoopCount = LoopCount + 1
                                ElseIf RangeCollection(x) = RNGtoCompare Then
                                    LoopCount = LoopCount + 1
                                End If
                                RangeCollection.Remove (x)
                                x = x - 1
                                If LoopCount = 2 Then
                                    Exit For
                                End If
                            End If
                        Next x
                        RangeCollection.Add MergedRNG
                        RNGtoCompare = RangeCollection(1)
                        RangeCollectionCount = RangeCollection.Count - MergeCount
                        k = RangeCollection.Count
                        j = j - 1
                        Exit For
                    ElseIf BaseRow = CurrentRow And FirstHalfColNum - 1 = CurrentColNum Then                        '***** CurrentCol is to the Left of Base Column *****
                        MergedRNG = CurrentLetter & BaseRow & ":" & SecondHalfBaseLetter & BaseRow
                        BaseRNGisMerged = True
                        MergeCount = MergeCount + 1     
                        LoopCount = 0
                        For x = 1 To RangeCollection.Count
                            If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                                If RangeCollection(x) = CurrentRNGValue Then
                                    LoopCount = LoopCount + 1
                                ElseIf RangeCollection(x) = RNGtoCompare Then
                                    LoopCount = LoopCount + 1
                                End If
                                RangeCollection.Remove (x)
                                x = x - 1
                                If LoopCount = 2 Then
                                    Exit For
                                End If
                            End If
                        Next x
                            
                        RangeCollection.Add MergedRNG
                        RNGtoCompare = RangeCollection(1)

                        j = j - 1
                        k = RangeCollection.Count
                        RangeCollectionCount = RangeCollection.Count - MergeCount
                        Exit For
                    End If
                    
                ElseIf BaseRNGisMerged = False And LoopRNGisMerged = True And Len(CurrentRNGValue) - Len(Replace(CurrentRNGValue, "/", "")) = 1 Then     ' Base Range is NOT merged, Loop Range is Merged
                    BaseLetter = Split(Columns(Range(RNGtoCompare).Column).Address(, False), ":")(1)
                    BaseColNum = Range(BaseLetter & 1).Column
                    BaseRow = Range(RNGtoCompare).Row
    
                    HyphenLoc = InStr(CurrentRNGValue, ":")
                    FirstHalfCurrentRNG = Left(CurrentRNGValue, HyphenLoc - 1)
                    FirstHalfCurrentLetter = Split(Columns(Range(FirstHalfCurrentRNG).Column).Address(, False), ":")(1)
                    FirstHalfCurrentColNum = Range(FirstHalfCurrentLetter & 1).Column
                    SecondHalfCurrentRNG = Right(CurrentRNGValue, Len(CurrentRNGValue) - HyphenLoc)
                    SecondHalfCurrentLetter = Split(Columns(Range(SecondHalfCurrentRNG).Column).Address(, False), ":")(1)
                    SecondHalfCurrentColNum = Range(SecondHalfCurrentLetter & 1).Column
                    CurrentRow = Range(SecondHalfCurrentRNG).Row
                    
                    If BaseRow = CurrentRow And BaseColNum + 1 = FirstHalfCurrentColNum Then                        '***** CurrentCol is to the Right of Base Column *****
                        MergedRNG = BaseLetter & BaseRow & ":" & SecondHalfCurrentLetter & BaseRow
                        BaseRNGisMerged = True
                        MergeCount = MergeCount + 1
    
                        LoopCount = 0
                        For x = 1 To RangeCollection.Count
                            If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                                If RangeCollection(x) = CurrentRNGValue Then
                                    LoopCount = LoopCount + 1
                                ElseIf RangeCollection(x) = RNGtoCompare Then
                                    LoopCount = LoopCount + 1
                                End If
                                RangeCollection.Remove (x)
                                x = x - 1
                                If LoopCount = 2 Then
                                    Exit For
                                End If
                            End If
                        Next x
                            
                        RangeCollection.Add MergedRNG
                        RNGtoCompare = RangeCollection(1)
                        RangeCollectionCount = RangeCollection.Count - MergeCount
                        k = RangeCollection.Count
                        j = j - 1
                        Exit For
                    ElseIf BaseRow = CurrentRow And BaseColNum - 1 = SecondHalfCurrentColNum Then                   '***** CurrentCol is to the Left of Base Column *****
                        MergedRNG = FirstHalfCurrentLetter & BaseRow & ":" & BaseLetter & BaseRow
                        BaseRNGisMerged = True
                        MergeCount = MergeCount + 1

                        LoopCount = 0
                        For x = 1 To RangeCollection.Count
                            If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                                If RangeCollection(x) = CurrentRNGValue Then
                                    LoopCount = LoopCount + 1
                                ElseIf RangeCollection(x) = RNGtoCompare Then
                                    LoopCount = LoopCount + 1
                                End If
                                RangeCollection.Remove (x)
                                x = x - 1
                                If LoopCount = 2 Then
                                    Exit For
                                End If
                            End If
                        Next x
                            
                        RangeCollection.Add MergedRNG
                        RNGtoCompare = RangeCollection(1)

                        If k = RangeCollectionCount And RangeCollection(k) = RNGtoCompare Then
                            RNGtoCompare = RangeCollection(1)
                        End If
                        RangeCollectionCount = RangeCollection.Count - MergeCount
                        k = RangeCollection.Count
                        j = j - 1
                        Exit For
                    End If
                End If
            End If

            If RNGtoCompare = RangeCollection(RangeCollection.Count - 1) And RangeCollection.Count = k Then
                RNGtoCompare = RangeCollection(1)
                Exit For
            ElseIf j = RangeCollection.Count - 1 And k = RangeCollection.Count Then
                Exit For
            ElseIf j = RangeCollection.Count And k = RangeCollection.Count Then
                Exit For
            End If
        end if
    Next k
Next j
    
' END of HORIZONTAL GROUPING


' BEGINNING of VERTICAL GROUPING
RangeCollectionCount = RangeCollection.Count
RNGtoCompare = ""
CurrentRNGValue = ""
MergedRNG = ""
MergeCount = 0
If RangeCollection.Count > 2 Then
    For m = 1 To RangeCollectionCount
        RNGtoCompare = RangeCollection(m)
        If m > RangeCollection.Count Then
            Exit For
        End If
        If InStr(RangeCollection(m), ":") > 0 Or InStr(RNGtoCompare, ":") > 0 Then
            BaseRNGisMerged = True
        Else
            RNGtoCompare = RangeCollection(m)               ' Sets Value that rest of collection would compare to
            BaseRNGisMerged = False
        End If
        If RNGtoCompare = "" Then
            RNGtoCompare = RangeCollection(1)
        End If
        For n = 1 To RangeCollection.Count - MergeCount           
            If Not RNGtoCompare = RangeCollection(n) Then   ' This conditional statement ensures comparision to itself does not occur
                CurrentRNGValue = RangeCollection(n)
                If InStr(CurrentRNGValue, ":") > 0 Then
                    LoopRNGisMerged = True
                Else
                    LoopRNGisMerged = False
                End If
                If InStr(RNGtoCompare, ":") > 0 Then
                    BaseRNGisMerged = True
                Else
                    BaseRNGisMerged = False
                End If
            Else
                GoTo Endn
            End If
            
            ' START OF LOOP TO CHECK FOR ALL MERGED ENTRIES
            If BaseRNGisMerged = True And LoopRNGisMerged = True Then   ' Checks to see if Base and Current Range is a Merged Range *** FOR MERGED RANGES ***
                HyphenLoc = InStr(RNGtoCompare, ":")
                FirstHalfBaseRNG = Left(RNGtoCompare, HyphenLoc - 1)
                FirstHalfBaseLetter = Split(Columns(Range(FirstHalfBaseRNG).Column).Address(, False), ":")(1)
                FirstHalfBaseColNum = Range(FirstHalfBaseLetter & 1).Column
                SecondHalfBaseRNG = Right(RNGtoCompare, Len(RNGtoCompare) - HyphenLoc)
                SecondHalfBaseLetter = Split(Columns(Range(SecondHalfBaseRNG).Column).Address(, False), ":")(1)
                SecondHalfBaseColNum = Range(SecondHalfBaseLetter & 1).Column
                FirstHalfBaseRow = Range(FirstHalfBaseRNG).Row
                SecondHalfBaseRow = Range(SecondHalfBaseRNG).Row
    
                HyphenLoc = InStr(CurrentRNGValue, ":")
                FirstHalfCurrentRNG = Left(CurrentRNGValue, HyphenLoc - 1)
                FirstHalfCurrentLetter = Split(Columns(Range(FirstHalfCurrentRNG).Column).Address(, False), ":")(1)
                FirstHalfCurrentColNum = Range(FirstHalfCurrentLetter & 1).Column
                SecondHalfCurrentRNG = Right(CurrentRNGValue, Len(CurrentRNGValue) - HyphenLoc)
                SecondHalfCurrentLetter = Split(Columns(Range(SecondHalfCurrentRNG).Column).Address(, False), ":")(1)
                SecondHalfCurrentColNum = Range(SecondHalfCurrentLetter & 1).Column
                FirstHalfCurrentRow = Range(FirstHalfCurrentRNG).Row
                SecondHalfCurrentRow = Range(SecondHalfCurrentRNG).Row
            
                If FirstHalfBaseLetter = FirstHalfCurrentLetter And SecondHalfBaseLetter = SecondHalfCurrentLetter And SecondHalfBaseRow + 1 = FirstHalfCurrentRow Then  ' Checks all Base and Current Merged Ranges
                    MergedRNG = FirstHalfBaseLetter & FirstHalfBaseRow & ":" & SecondHalfCurrentLetter & SecondHalfCurrentRow
                    BaseRNGisMerged = True
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count - MergeCount
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                            CurrX = RangeCollection(x)
                                    
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                         End If
                    Next x
                    RangeCollection.Add MergedRNG
                    RNGtoCompare = MergedRNG
                    RangeCollectionCount = RangeCollection.Count
                    m = m - 1
                    If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                        RNGtoCompare = RangeCollection(m)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B1:B10000").Interior.Color = RGB(255, 255, 255)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B" & m).Interior.Color = RGB(0, 255, 0)
                        Exit For
                    End If
                    GoTo Endm
                ElseIf FirstHalfBaseLetter = FirstHalfCurrentLetter And SecondHalfBaseLetter = SecondHalfCurrentLetter And FirstHalfBaseRow - 1 = SecondHalfCurrentRow Then
                    MergedRNG = FirstHalfCurrentLetter & FirstHalfCurrentRow & ":" & SecondHalfCurrentLetter & SecondHalfBaseRow
                    BaseRNGisMerged = True
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count - MergeCount
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                            CurrX = RangeCollection(x)
                                        
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                            End If
                    Next x
                    RangeCollection.Add MergedRNG
                    RNGtoCompare = MergedRNG
                    RangeCollectionCount = RangeCollection.Count
                    m = m - 1
                    If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                        RNGtoCompare = RangeCollection(m)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B1:B10000").Interior.Color = RGB(255, 255, 255)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B" & m).Interior.Color = RGB(0, 255, 0)
                        Exit For
                    End If
                    GoTo Endm
                End If
            ElseIf BaseRNGisMerged = True And LoopRNGisMerged = False Then   ' Base if Merged, Loop is not Merged
                HyphenLoc = InStr(RNGtoCompare, ":")
                FirstHalfBaseRNG = Left(RNGtoCompare, HyphenLoc - 1)
                FirstHalfBaseLetter = Split(Columns(Range(FirstHalfBaseRNG).Column).Address(, False), ":")(1)
                FirstHalfBaseColNum = Range(FirstHalfBaseLetter & 1).Column
                SecondHalfBaseRNG = Right(RNGtoCompare, Len(RNGtoCompare) - HyphenLoc)
                SecondHalfBaseLetter = Split(Columns(Range(SecondHalfBaseRNG).Column).Address(, False), ":")(1)
                SecondHalfBaseColNum = Range(SecondHalfBaseLetter & 1).Column
                FirstHalfBaseRow = Range(FirstHalfBaseRNG).Row
                SecondHalfBaseRow = Range(SecondHalfBaseRNG).Row
                
                CurrentLetter = Split(Columns(Range(CurrentRNGValue).Column).Address(, False), ":")(1)
                CurrentColNum = Range(CurrentLetter & 1).Column
                CurrentRow = Range(CurrentRNGValue).Row
            
                If FirstHalfBaseLetter = SecondHalfBaseLetter And FirstHalfBaseLetter = CurrentLetter And FirstHalfBaseRow - 1 = CurrentRow Then
                    MergedRNG = CurrentLetter & CurrentRow & ":" & CurrentLetter & SecondHalfBaseRow
                    BaseRNGisMerged = True
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count - MergeCount
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                            CurrX = RangeCollection(x)
                                        
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                        End If
                    Next x
                    RangeCollection.Add MergedRNG
                    RNGtoCompare = MergedRNG
                    RangeCollectionCount = RangeCollection.Count
                    m = m - 1
                    If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                        RNGtoCompare = RangeCollection(m)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B1:B10000").Interior.Color = RGB(255, 255, 255)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B" & m).Interior.Color = RGB(0, 255, 0)
                        Exit For
                    End If
                    GoTo Endm
                ElseIf FirstHalfBaseLetter = SecondHalfBaseLetter And FirstHalfBaseLetter = CurrentLetter And SecondHalfBaseRow + 1 = CurrentRow Then
                    MergedRNG = CurrentLetter & FirstHalfBaseRow & ":" & CurrentLetter & CurrentRow
                    BaseRNGisMerged = True
                    MergeCount = MergeCount + 1
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                            CurrX = RangeCollection(x)
                                        
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                        End If
                    Next x
                    RangeCollection.Add MergedRNG
                    RNGtoCompare = MergedRNG
                    RangeCollectionCount = RangeCollection.Count
                    m = m - 1
                    If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                        RNGtoCompare = RangeCollection(m)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B1:B10000").Interior.Color = RGB(255, 255, 255)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B" & m).Interior.Color = RGB(0, 255, 0)
                        Exit For
                    End If
                    GoTo Endm
                End If
            ElseIf BaseRNGisMerged = False And LoopRNGisMerged = False Then   ' Both are Unmerged
                BaseLetter = Split(Columns(Range(RNGtoCompare).Column).Address(, False), ":")(1)
                BaseColNum = Range(BaseLetter & 1).Column
                BaseRow = Range(RNGtoCompare).Row
                    
                CurrentLetter = Split(Columns(Range(CurrentRNGValue).Column).Address(, False), ":")(1)
                CurrentColNum = Range(CurrentLetter & 1).Column
                CurrentRow = Range(CurrentRNGValue).Row
                
                If BaseLetter = CurrentLetter And BaseRow + 1 = CurrentRow Then
                    MergedRNG = BaseLetter & BaseRow & ":" & BaseLetter & CurrentRow
                    BaseRNGisMerged = True
                    MergeCount = MergeCount + 1
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count - MergeCount
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                            CurrX = RangeCollection(x)
                                        
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                        End If
                    Next x
                    RangeCollection.Add MergedRNG
                    RNGtoCompare = MergedRNG
                    RangeCollectionCount = RangeCollection.Count
                    If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                        RNGtoCompare = RangeCollection(m)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B1:B10000").Interior.Color = RGB(255, 255, 255)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B" & m).Interior.Color = RGB(0, 255, 0)
                        Exit For
                    End If
                    m = m - 1
                    GoTo Endm
                ElseIf BaseLetter = CurrentLetter And BaseRow - 1 = CurrentRow Then
                    MergedRNG = BaseLetter & CurrentRow & ":" & BaseLetter & BaseRow
                    BaseRNGisMerged = True
                                                        
                    LoopCount = 0
                    For x = 1 To RangeCollection.Count
                        If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                            CurrX = RangeCollection(x)
                                        
                            If RangeCollection(x) = CurrentRNGValue Then
                                LoopCount = LoopCount + 1
                            ElseIf RangeCollection(x) = RNGtoCompare Then
                                LoopCount = LoopCount + 1
                            End If
                            RangeCollection.Remove (x)
                            x = x - 1
                            If LoopCount = 2 Then
                                Exit For
                            End If
                        End If
                    Next x
                    RangeCollection.Add MergedRNG
                    RNGtoCompare = MergedRNG
                    RangeCollectionCount = RangeCollection.Count - MergeCount
                    m = m - 1
                    If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                        RNGtoCompare = RangeCollection(m)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B1:B10000").Interior.Color = RGB(255, 255, 255)
                        ThisWorkbook.Worksheets("Unique Ranges").Range("B" & m).Interior.Color = RGB(0, 255, 0)
                        Exit For
                    End If
                    GoTo Endm
                End If
                
            End If
            
            If RNGtoCompare = RangeCollection(RangeCollection.Count) Then
                RNGtoCompare = RangeCollection(m)
                Exit For
            End If

Endn:
        Next n
Endm:
    Next m
ElseIf RangeCollection.Count = 2 Then
    RNGtoCompare = RangeCollection(1)
    CurrentRNGValue = RangeCollection(2)
    If InStr(CurrentRNGValue, ":") > 0 Then
        LoopRNGisMerged = True
    Else
        LoopRNGisMerged = False
    End If
    If InStr(RNGtoCompare, ":") > 0 Then
        BaseRNGisMerged = True
    Else
        BaseRNGisMerged = False
    End If
    
If BaseRNGisMerged = True And LoopRNGisMerged = True Then
        HyphenLoc = InStr(RNGtoCompare, ":")
        FirstHalfBaseRNG = Left(RNGtoCompare, HyphenLoc - 1)
        FirstHalfBaseLetter = Split(Columns(Range(FirstHalfBaseRNG).Column).Address(, False), ":")(1)
        FirstHalfBaseColNum = Range(FirstHalfBaseLetter & 1).Column
        SecondHalfBaseRNG = Right(RNGtoCompare, Len(RNGtoCompare) - HyphenLoc)
        SecondHalfBaseLetter = Split(Columns(Range(SecondHalfBaseRNG).Column).Address(, False), ":")(1)
        SecondHalfBaseColNum = Range(SecondHalfBaseLetter & 1).Column
        FirstHalfBaseRow = Range(FirstHalfBaseRNG).Row
        SecondHalfBaseRow = Range(SecondHalfBaseRNG).Row

        HyphenLoc = InStr(CurrentRNGValue, ":")
        FirstHalfCurrentRNG = Left(CurrentRNGValue, HyphenLoc - 1)
        FirstHalfCurrentLetter = Split(Columns(Range(FirstHalfCurrentRNG).Column).Address(, False), ":")(1)
        FirstHalfCurrentColNum = Range(FirstHalfCurrentLetter & 1).Column
        SecondHalfCurrentRNG = Right(CurrentRNGValue, Len(CurrentRNGValue) - HyphenLoc)
        SecondHalfCurrentLetter = Split(Columns(Range(SecondHalfCurrentRNG).Column).Address(, False), ":")(1)
        SecondHalfCurrentColNum = Range(SecondHalfCurrentLetter & 1).Column
        FirstHalfCurrentRow = Range(FirstHalfCurrentRNG).Row
        SecondHalfCurrentRow = Range(SecondHalfCurrentRNG).Row
        
        If FirstHalfBaseColNum = FirstHalfCurrentColNum And SecondHalfBaseColNum = SecondHalfCurrentColNum And SecondHalfBaseRow + 1 = FirstHalfCurrentRow Then   ' RangeCollection(2) is adjacent and below RangeCollection(1)
            MergedRNG = FirstHalfBaseLetter & FirstHalfBaseRow & ":" & SecondHalfCurrentLetter & SecondHalfCurrentRow
            BaseRNGisMerged = True
            MergeCount = MergeCount + 1
            LoopCount = 0
            For x = 1 To RangeCollection.Count - MergeCount
                If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                    CurrX = RangeCollection(x)
                                
                    If RangeCollection(x) = CurrentRNGValue Then
                        LoopCount = LoopCount + 1
                    ElseIf RangeCollection(x) = RNGtoCompare Then
                        LoopCount = LoopCount + 1
                    End If
                    RangeCollection.Remove (x)
                    x = x - 1
                    If LoopCount = 2 Then
                        Exit For
                    End If
                    End If
            Next x
            RangeCollection.Add MergedRNG
        ElseIf FirstHalfBaseColNum = FirstHalfCurrentColNum And SecondHalfBaseColNum = SecondHalfCurrentColNum And FirstHalfBaseRow - 1 = SecondHalfCurrentRow Then   ' RangeCollection(2) is adjacent and above RangeCollection(1)
            MergedRNG = FirstHalfCurrentLetter & FirstHalfCurrentRow & ":" & SecondHalfBaseLetter & SecondHalfBaseRow
            BaseRNGisMerged = True
            MergeCount = MergeCount + 1
            LoopCount = 0
            For x = 1 To RangeCollection.Count - MergeCount
                If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                    CurrX = RangeCollection(x)
                                
                    If RangeCollection(x) = CurrentRNGValue Then
                        LoopCount = LoopCount + 1
                    ElseIf RangeCollection(x) = RNGtoCompare Then
                        LoopCount = LoopCount + 1
                    End If
                    RangeCollection.Remove (x)
                    x = x - 1
                    If LoopCount = 2 Then
                        Exit For
                    End If
                    End If
            Next x
            RangeCollection.Add MergedRNG
        End If
 
    ElseIf BaseRNGisMerged = False And LoopRNGisMerged = False Then
        BaseLetter = Split(Columns(Range(RNGtoCompare).Column).Address(, False), ":")(1)
        BaseColNum = Range(BaseLetter & 1).Column
        BaseRow = Range(RNGtoCompare).Row
                    
        CurrentLetter = Split(Columns(Range(CurrentRNGValue).Column).Address(, False), ":")(1)
        CurrentColNum = Range(CurrentLetter & 1).Column
        CurrentRow = Range(CurrentRNGValue).Row
        
        If BaseLetter = CurrentLetter And BaseRow + 1 = CurrentRow Then
            MergedRNG = BaseLetter & BaseRow & ":" & BaseLetter & CurrentRow
            BaseRNGisMerged = True
                                                
            LoopCount = 0
            For x = 1 To RangeCollection.Count - MergeCount
                If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                    CurrX = RangeCollection(x)
                                
                    If RangeCollection(x) = CurrentRNGValue Then
                        LoopCount = LoopCount + 1
                    ElseIf RangeCollection(x) = RNGtoCompare Then
                        LoopCount = LoopCount + 1
                    End If
                    RangeCollection.Remove (x)
                    x = x - 1
                    If LoopCount = 2 Then
                        Exit For
                    End If
                    End If
            Next x
            RangeCollection.Add MergedRNG
        ElseIf BaseLetter = CurrentLetter And BaseRow - 1 = CurrentRow Then
            MergedRNG = BaseLetter & CurrentRow & ":" & BaseLetter & BaseRow
            BaseRNGisMerged = True
                                                
            LoopCount = 0
            For x = 1 To RangeCollection.Count - MergeCount
                If RangeCollection(x) = CurrentRNGValue Or RangeCollection(x) = RNGtoCompare Then
                    CurrX = RangeCollection(x)
                                
                    If RangeCollection(x) = CurrentRNGValue Then
                        LoopCount = LoopCount + 1
                    ElseIf RangeCollection(x) = RNGtoCompare Then
                        LoopCount = LoopCount + 1
                    End If
                    RangeCollection.Remove (x)
                    x = x - 1
                    If LoopCount = 2 Then
                        Exit For
                    End If
                    End If
            Next x
            RangeCollection.Add MergedRNG
        End If
    End If

End If

RangeCollectionCount = RangeCollection.Count
RNGtoCompare = ""
CurrentRNGValue = ""
MergedRNG = ""
' END of VERTICAL GROUPING
    
If RangeCollection.Count > 0 Then
    
    For n = 1 To RangeCollection.Count
        If Not Right(CombinedRanges, 1) = "," And Len(CombinedRanges) > 0 Then
            CombinedRanges = CombinedRanges & ","
        End If
        CombinedRanges = CombinedRanges & RangeCollection(n) & ","
    Next n
    CombinedRanges = Left(CombinedRanges, Len(CombinedRanges) - 1)
    GroupCollectionRNG = CombinedRanges
    
End If

Set RangeCollection = Nothing
Application.ScreenUpdating = True

End Function
 
Upvote 0
pingme89 said:
All the cell ranges are single cell ranges to begin with. The initial Ranges are all single cell ranges and not paired so it doesn't work for me in this case. Ideally, I want to call a function and pass a Collection of Single ranges to the Function and return the grouped ranges. My code is quite long and although it seems to work, I may have overcomplicated it thus the run time being excessively long.
This is what I have. But any improvement would be greatly appreciated.
Click to expand...
<snip>
By definition a range is 2 or more cells. Saying "single cell ranges" is a contradiction of terms. In the original data presented "B22, B23, C22, C23, A48, A49, A50, R26, S26, T26", is a series of cells separated by commas. It's also unclear how long that string of cells might be - 100, 1,000?

I'll admit I'm not a VBA fan, but that's a LOT of code for a relatively simple operation! LAMBDA functions can be recursive. I'm sure that it can be done more reliably that way. That's a LOT of code to maintain!
 
Last edited:
Upvote 0
pingme89 said:
Given a list of single cell ranges such as B22, B23, C22, C23, A48, A49, A50, R26, S26, T26

I want to write an algorithm that would group adjacent cells together to be in the above example "B22:C23, A49:A50, R26:T26"
I have almost solved the problem, but my solution is very slow.
Click to expand...
Maybe something like this:

VBA Code: 
Sub pingme89()

Dim r As Range, f As Range
Dim x
For Each x In Split("B22,B23,C22,C23,A48,A49,A50,R26,S26,T26", ",")
      If r Is Nothing Then
        Set r = Range(x)
      Else
        Set r = Union(r, Range(x))
      End If
Next

Debug.Print r.Address(0, 0) 'returns:  B22:C23,A48:A50,R26:T26

For Each f In r.Areas
    Debug.Print f.Address(0, 0)
            'returns:
            'B22:C23
            'A48:A50
            'R26:T26
Next

End Sub
 
Upvote 0
Is there any way to tweak that into a function taking the input as a Collection like in my original code? Then spitting out the Range as a string?
It will take me a while to take my collection of data to test what you wrote.

Thanks.
 
Upvote 0
pingme89 said:
Is there any way to tweak that into a function taking the input as a Collection like in my original code? Then spitting out the Range as a string?
Click to expand...

Sorry, I don't understand your code. What collection & how do you get it?
 
Upvote 0
A collection is a group of data.
You can create one using the following code:

VBA Code: 
Dim GroupedRNG As New Collection
ItemCount = 20

For i = 1 To ItemCount
    GroupedRNG.Add ThisWorkbook.Worksheets("Info").Range("AA" & i).Value
Next i

The Function I created is called GroupCollectionRNG, and in the above example of the Collection named "GroupedRNG"
I call the function as follows:

VBA Code: 
MergedRanges = GroupCollectionRNG(GroupedRNG)

The following code is to make the function that takes the Collection as input. Note that there are no commas as delimiters in the range.
You can Call each item of the range with the following code:

VBA Code: 
for x = 1 to 20
      RNG = GroupedRNG(x)
next x

VBA Code: 
Private Function GroupCollectionRNG(ByRef RangeCollection As VBA.Collection)
Dim sheet As Worksheet
Dim MergeCount As Long

RangeCollectionCount = RangeCollection.Count

.
.

GroupCollectionRNG = MergedRange  ' This would take all the grouped ranges and pass the data back as a string result

End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Trouble expanding cell range in a vLookup in a macro
Replies
6
Views
309
NoSuperUserHere
N
E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
298
offthelip
O
J
  • Solved
My Two Calculators Don't Match
Replies
1
Views
103
Peter_SSs
Peter_SSs
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
243
Coco1
C
S
  • Question
"Subscript out of range ( Run time Error: 09)" Problem in My Excel VBA
Replies
5
Views
282
6StringJazzer
6StringJazzer

Forum statistics

Threads
1,215,391
Messages
6,124,673
Members
449,178
Latest member
Emilou

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