Private Function GroupCollectionRNG(ByRef RangeCollection As VBA.Collection)
Dim sheet As Worksheet
Dim MergeCount As Long
RangeCollectionCount = RangeCollection.Count
For i = 1 To RangeCollectionCount
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
End If
For x = 1 To RangeCollectionCount
RangeCollection.Remove (1)
Next x
For i = 1 To RangeCollectionCount
RNGvalue = ThisWorkbook.Worksheets("Unique Ranges").Range("A" & i).Value
RangeCollection.Add RNGvalue
Next i
MergeCount = 0
ThisWorkbook.Worksheets("Unique Ranges").Range("A1:C10000").ClearContents
On Error Resume Next
For j = 1 To RangeCollectionCount - MergeCount
If InStr(RangeCollection(j), ":") > 0 Or InStr(RNGtoCompare, ":") > 0 Then
BaseRNGisMerged = True
Else
RNGtoCompare = RangeCollection(j)
BaseRNGisMerged = False
End If
For k = 1 To RangeCollectionCount - MergeCount
If Not RNGtoCompare = RangeCollection(k) Then
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
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
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
ElseIf BaseRow = CurrentRow And BaseColNum - 1 = CurrentColNum Then
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
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
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
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
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
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
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
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)
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
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
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 FirstHalfBaseLetter = FirstHalfCurrentLetter And SecondHalfBaseLetter = SecondHalfCurrentLetter And SecondHalfBaseRow + 1 = FirstHalfCurrentRow Then
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
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
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
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
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 = ""
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