Find range subset combinations from main range in Excel via VBA - excel

Question

Here are the particulars. Let's say you have a 10 X 10 range of cells- A1:J10 will work fine. What I'm trying to find via VBA is how many pairs of non intersecting ranges containing 5 cells and 4 cells can be derived from the main range of A1:J10. For example, A1:A5 (5 cell subset) and A6:A9 (4 cell subset) would be a valid pair. A1:E5 and A1:A4 would not be a valid pair due to the intersection of ranges at A1. I'm mostly just looking for the number of valid pairs, but if somebody can show how to physically list all the pairs on a worksheet as well that would help out.
Thanks in advance for the help!

Answer 1

Range Subset Combinations
Option Explicit
Sub writeRangePairs()
' Source
Const wsName As String = "Sheet1"
Const srcRange = "A1:J10"
Const RC1 As Long = 5
Const RC2 As Long = 4
' Target
Const tgtFirstCell As String = "L1"
' Other
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Source Range.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim rng As Range
Set rng = ws.Range(srcRange)
' Write all possible range addresses
' to Source Arrays ('Source1', 'Source2').
Dim Source1 As Variant
Source1 = getOneRowOneCol(rng, RC1)
Dim Source2 As Variant
Source2 = getOneRowOneCol(rng, RC2)
' Define Target Array. It is too big,
' but It cannot be bigger than UB1 * UB2.
Dim Target As Variant
ReDim Target(1 To UBound(Source1) * UBound(Source2), 1 To 3)
Dim i As Long
Dim k As Long
Dim m As Long
' Write values from Source Arrays to Target Array.
For i = 1 To UBound(Source1)
For k = 1 To UBound(Source2)
If Intersect(ws.Range(Source1(i, 1)), ws.Range(Source2(k, 1))) _
Is Nothing Then
m = m + 1
' Write first range address.
Target(m, 1) = Source1(i, 1)
' Write second range address.
Target(m, 2) = Source2(k, 1)
' Write both addresses as one range address. This column
' will contain duplicates which could be removed
' by using a dictionary.
Target(m, 3) = Union(ws.Range(Source1(i, 1)), _
ws.Range(Source2(k, 1))).Address(0, 0)
End If
Next k
Next i
' Write values from Target Array to Target Range. Since Target Array
' is too big, we are using 'm' instead of 'UBound(Target, 1)'.
ws.Range(tgtFirstCell).Resize(m, UBound(Target, 2)).Value = Target
End Sub
Function getOneRowOneCol(SourceRange As Range, _
ByVal NumberOfCells As Long) _
As Variant
Dim r As Long
r = SourceRange.Rows.Count
Dim c As Long
c = SourceRange.Columns.Count
Dim NoRs As Long
NoRs = r * (c - NumberOfCells + 1)
Dim NoCs As Long
NoCs = c * (r - NumberOfCells + 1)
Dim Data As Variant
ReDim Data(1 To NoRs + NoCs, 1 To 1)
Dim rng As Range
Dim i As Long
Dim j As Long
Dim k As Long
' Rows
For i = 1 To r
For j = 1 To c - NumberOfCells + 1
Set rng = SourceRange.Cells(i, j).Resize(, NumberOfCells)
k = k + 1
Data(k, 1) = rng.Address(0, 0)
Next j
Next i
' Columns
For j = 1 To c
For i = 1 To r - NumberOfCells + 1
Set rng = SourceRange.Cells(i, j).Resize(NumberOfCells)
k = k + 1
Data(k, 1) = rng.Address(0, 0)
Next i
Next j
getOneRowOneCol = Data
' Debug.Print UBound(Data)
' For i = 1 To UBound(Data)
' Debug.Print Data(i, 1)
' Next i
End Function