通过 VBA 从 Excel 中的主范围中查找范围子集组合

Question

这里是细节。假设您有 10 X 10 范围的单元格 - A1:J10 可以正常工作。我试图通过 VBA 找到的是，可以从 A1:J10 的主要范围派生多少对包含 5 个单元格和 4 个单元格的非相交范围。例如，A1:A5（5 个细胞子集）和 A6:A9（4 个细胞子集）将是一个有效的对。由于 A1 的范围相交，A1:E5 和 A1:A4 将不是有效对。我主要只是在寻找有效对的数量，但如果有人可以展示如何在工作表上物理列出所有对，那将有所帮助。

提前感谢您的帮助！

Answer 1

范围子集组合

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