Range Grouping problem

[pingme89]

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".

 

[jdellasala]

There's no way to sort on the color without breaking out the values. Here's one way to do that:

Book1
	A	B	C	D
1	ActiveSheet.Range("A1").interior.color = rgb(255,255,255)	255	255	255
2	ActiveSheet.Range("A2").interior.color = rgb(255,255,255)	255	255	255
3	ActiveSheet.Range("A3").interior.color = rgb(255,255,255)	255	255	255
4	ActiveSheet.Range("A4").interior.color = rgb(255,255,255)	255	255	255
5	ActiveSheet.Range("B2").interior.color = rgb(255,20,50)	255	20	50
6	ActiveSheet.Range("C2").interior.color = rgb(255,20,50)	255	20	50
7	ActiveSheet.Range("D2").interior.color = rgb(255,20,50)	255	20	50
8	ActiveSheet.Range("B3").interior.color = rgb(255,20,50)	255	20	50
9	ActiveSheet.Range("C3").interior.color = rgb(255,20,50)	255	20	50
10	ActiveSheet.Range("D3").interior.color = rgb(255,20,50)	255	20	50
Sheet1

Cell Formulas
Range	Formula
B1:D10	B1	=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:

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!

 

[pingme89]

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.

 

[jdellasala]

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
	A	B	C
1	Column1		Ranges
2	B22, B23, C22, C23, A48, A49, A50, R26, S26, T26		B22:C23
3			A48:R26
Sheet2

This is the M Code for the 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?!).

 

[pingme89]

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.

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

 

[jdellasala]

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.

<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!

 

[Akuini]

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.

Maybe something like this:

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

 

[pingme89]

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.

 

[Akuini]

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?

Sorry, I don't understand your code. What collection & how do you get it?

 

[pingme89]

A collection is a group of data.
You can create one using the following 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:

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:

for x = 1 to 20
      RNG = GroupedRNG(x)
next x

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