組み合わせパターン表を作るExcelマクロ

これは何？

複数の要素の全組み合わせ、って、まあよくあるやつです。
要素を書き並べておいて、ボタン一つでいい感じに表にしたかった。

イメージ

コード

Option Explicit

Sub 組み合わせ表()
    Dim t As Range, d As Range, e As Range, r As Range
    With ActiveCell.CurrentRegion
        Set t = .Resize(1)
        Set d = t.Offset(, t.Count + 1)
        t.Copy d
        For Each e In t
            Set r = PatternMatrix(r, e.Offset(1).Resize(e.End(xlDown).Row - e.Row), d.Offset(1))
        Next
    End With
    SmartBorder d.CurrentRegion
End Sub

Private Function PatternMatrix(baseRange As Range, addRange As Range, distRange As Range) As Range
    Dim arx, acx, aar
    aar = ToArray(addRange)
    arx = UBound(aar)
    acx = 1
    Dim brx, bcx, bar
    If baseRange Is Nothing Then
        brx = 1
    Else
        bar = ToArray(baseRange)
        brx = UBound(bar, 1)
        bcx = UBound(bar, 2)
    End If
    Dim rx, cx, arr
    rx = brx * arx
    cx = bcx + acx
    Set PatternMatrix = distRange.Resize(rx, cx)
    arr = ToArray(PatternMatrix)
    Dim br, bc, ar, ac, r, c
    For br = 1 To brx: For ar = 1 To arx
        r = r + 1
        For c = 1 To bcx
            arr(r, c) = IIf(ar = 1, bar(br, c), vbNullString)
        Next c
        arr(r, bcx + 1) = aar(ar, 1)
    Next ar, br
    PatternMatrix.Value = arr
End Function

Private Function SmartBorder(Optional rng As Range) As Range
    Set SmartBorder = IIf(rng Is Nothing, ActiveWindow.RangeSelection, rng)
    With SmartBorder
        .Borders.LineStyle = xlNone
        .BorderAround xlContinuous
        For Each rng In .Cells
            If Not IsEmpty(rng) Then rng.Resize(.Cells(.Count).Row - rng.Row + 1, .Cells(.Count).Column - rng.Column + 1).BorderAround xlContinuous
        Next
    End With
End Function

Private Function ToArray(rng As Range) As Variant
    ToArray = rng.Value
    If Not IsArray(ToArray) Then
        Dim wArr(1 To 1, 1 To 1)
        wArr(1, 1) = ToArray
        ToArray = wArr
    End If
End Function

追記（2020.1.26）

うまく動かなくなったので修正しました。