Return to Revisions

3 of 4

added 1757 characters in body

edited Aug 18, 2019 at 7:27

4.3k
1
13
25

75K Non-Contiguous Areas, No Problem

My FastUnion class was able to crack the 75K non-contiguous areas goal by expanding on Ahmed AU answer using Union() with multiple parameters. Although, this class excels at smaller numbers of areas, my UnionCollection class far out performs it by working with smaller groups of cells at a time.

[![enter image description here][1]][1]

Results

Immediate Window ScreenShot [1]: https://i.sstatic.net/K6U9E.png

FastUnion:Class

Option Explicit
Private Const MaxArgs As Long = 30
Private Groups(1 To MaxArgs) As Range
Private Index As Long
Private Count As Long
Private Compacted As Boolean

Public Sub Add(ByRef NewRange As Range)
    If Count < MaxArgs Then Count = Count + 1
    Index = Index + 1
    If Index > MaxArgs Then Index = IIf(Compacted, 2, 1)
    If Groups(Index) Is Nothing Then
        Set Groups(Index) = NewRange
    Else
        Set Groups(Index) = Union(Groups(Index), NewRange)
    End If
End Sub

Private Sub Compact()
    Select Case Count
        Case 2
            Set Groups(1) = Union(Groups(1), Groups(2))
        Case 3
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3))
        Case 4
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4))
        Case 5
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5))
        Case 6
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6))
        Case 7
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7))
        Case 8
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8))
        Case 9
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9))
        Case 10
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10))
        Case 11
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11))
        Case 12
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12))
        Case 13
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13))
        Case 14
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14))
        Case 15
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15))
        Case 16
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16))
        Case 17
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17))
        Case 18
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18))
        Case 19
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19))
        Case 20
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20))
        Case 21
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21))
        Case 22
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22))
        Case 23
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23))
        Case 24
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24))
        Case 25
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24), Groups(25))
        Case 26
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24), Groups(25), Groups(26))
        Case 27
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24), Groups(25), Groups(26), Groups(27))
        Case 28
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24), Groups(25), Groups(26), Groups(27), Groups(28))
        Case 29
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24), Groups(25), Groups(26), Groups(27), Groups(28), Groups(29))
        Case 30
            Set Groups(1) = Union(Groups(1), Groups(2), Groups(3), Groups(4), Groups(5), Groups(6), Groups(7), Groups(8), Groups(9), Groups(10), Groups(11), Groups(12), Groups(13), Groups(14), Groups(15), Groups(16), Groups(17), Groups(18), Groups(19), Groups(20), Groups(21), Groups(22), Groups(23), Groups(24), Groups(25), Groups(26), Groups(27), Groups(28), Groups(29), Groups(30))
    End Select
    
    Dim n As Long
    For n = 2 To MaxArgs
        Set Groups(n) = Nothing
    Next
    Index = 2
    Compacted = True
    Count = 0
    
End Sub

Public Function getRange() As Range
    Compact
    Set getRange = Groups(1)
End Function

UnionCollection:Class

The Default number of cells in a group is set to 500 which may not be optimal. The optimal group size could be determined by testing different values for the CellCountGoal.

Option Explicit
Private Const DefaultCellCountGoal As Long = 500
Private RangeItems As New Collection
Private item As Range
Public CellCountGoal As Long

Public Sub Add(ByRef NewRange As Range)
    If item Is Nothing Then
        Set item = NewRange
    Else
        Set item = Union(item, NewRange)
    End If
    
    If item.CountLarge >= CellCountGoal Then Compact

End Sub

Private Sub Class_Initialize()
    CellCountGoal = DefaultCellCountGoal
End Sub

Public Function Items() As Collection
    Compact
    Set Items = RangeItems
End Function

Private Sub Compact()
    If Not item Is Nothing Then
        RangeItems.Add item
        Set item = Nothing
    End If
End Sub

Module1

Option Explicit

Sub TestFastUnion()
    Application.ScreenUpdating = False
    Debug.Print "TestFastUnionRange Results:"
    Debug.Print "Area Count", "UnionTime", "FormatTime", "ProcTime"

    TestFastUnionRange 1000, 2000, 3000, 5000, 10000, 75000
    
    Debug.Print
    Debug.Print "TestUnionCollection Results:"
    Debug.Print "Area Count", "UnionTime", "FormatTime", "ProcTime"
    
    TestUnionCollection 1000, 2000, 3000, 5000, 10000, 75000
    
    
End Sub

Sub TestFastUnionRange(ParamArray AreaCounts() As Variant)
    Dim AllCells As Range, Cell As Range
    Dim ProcTime As Double, FormatTime As Double, UnionTime As Double
    Dim NewUnion As FastUnion
    Dim AreaCount
    
    For Each AreaCount In AreaCounts
        Cells.ClearFormats
        Debug.Print AreaCount,
        ProcTime = Timer
        Set NewUnion = New FastUnion
        
        For Each Cell In Range("A1").Resize(AreaCount * 2)
            If Cell.Row Mod 2 = 0 Then NewUnion.Add Cell
        Next
        Set AllCells = NewUnion.getRange
        UnionTime = Round(Timer - ProcTime, 2)
        ApplyBorderFormmating AllCells, vbRed
        ProcTime = Round(Timer - ProcTime, 2)
        FormatTime = Round(ProcTime - UnionTime, 2)
        Debug.Print UnionTime, FormatTime, ProcTime
    Next
End Sub

Sub TestUnionCollection(ParamArray AreaCounts() As Variant)
    Dim Cell As Range, item As Range
    Dim ProcTime As Double, FormatTime As Double, UnionTime As Double
    Dim NewUnion As UnionCollection
    Dim AreaCount
    
    For Each AreaCount In AreaCounts
        Cells.ClearFormats
        Debug.Print AreaCount,
        ProcTime = Timer
        Set NewUnion = New UnionCollection
        
        For Each Cell In Range("A1").Resize(AreaCount * 2)
            If Cell.Row Mod 2 = 0 Then NewUnion.Add Cell
        Next
        
        UnionTime = Round(Timer - ProcTime, 2)
        For Each item In NewUnion.Items
            ApplyBorderFormmating item, vbRed
        Next
        
        ProcTime = Round(Timer - ProcTime, 2)
        FormatTime = Round(ProcTime - UnionTime, 2)
        Debug.Print UnionTime, FormatTime, ProcTime
    Next
End Sub

Sub ApplyBorderFormmating(Target As Range, Color As Single)
    With Target.Borders
        .Color = Color
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
End Sub

Sub PrintCases()
    Dim list As Object
    Set list = CreateObject("System.Collections.ArrayList")
    Dim n As Long
    For n = 1 To 30
        list.Add "Groups(" & n & ")"
        Debug.Print String(2, vbTab); "Case "; n
        Debug.Print String(3, vbTab); "Set AllCells = Union("; Join(list.ToArray, ","); ")"
    Next
End Sub

Edit

I modified the FastUnion class after I realized it would reset the range after Compact() was ran.

The OP pointed out I should list my specs.

System Specs

64 bit Office 365
6 GB Ram
2.3 MHz processor

Addendum

Here was my first attempt at cracking 75 K areas. It performed very well with smaller number of unions but started to slow down exponentially after 20 K unions. Although, it probably isn't practical, there may be some merit to combining it with the FastUnion. If nothing else it was interesting to write.

StingUnion:Class

Option Explicit
Private Const MaxAddressSize As Long = 255
Private CurrentLength As Long
Private Result As Range
Private Parent As Worksheet
Private AddressHolder As String

Public Sub Add(Source As Range)
    If Parent Is Nothing Then
        Set Parent = Source.Parent
        AddressHolder = Space(MaxAddressSize)
    End If
    
    Dim length As Long
    Dim Address As String
    Address = Source.Address(0, 0)
    length = Len(Address)
    
    If (length + CurrentLength) > MaxAddressSize Then Compact
    
    If CurrentLength = 0 Then
        Mid(AddressHolder, CurrentLength + 1, length + 1) = Address
    Else
        Mid(AddressHolder, CurrentLength + 1, length + 1) = "," & Address
    End If
    CurrentLength = CurrentLength + length + 1
    
End Sub

Public Sub Compact()
    If CurrentLength = 0 Then Exit Sub
    
    If Result Is Nothing Then
        Set Result = Parent.Range(AddressHolder)
    Else
        Set Result = Union(Result, Parent.Range(AddressHolder))
    End If
    
    CurrentLength = 0
    AddressHolder = Space(MaxAddressSize)
End Sub

Function getRange() As Range
    Compact
    Set getRange = Result
End Function

answered Aug 17, 2019 at 6:01

TinMan

4.3k
1
13
25