Алгоритм объединения VBA Excel в массив - PullRequest
0 голосов
/ 30 октября 2019

Может кто-нибудь помочь мне изменить приведенный ниже код. Это модификация существующего кода, который я видел в сообщении: Stackoverflow - Алгоритм комбинирования VBA Excel в массив Я попытался изменить пример в приведенной выше гиперссылке вместо вывода на лист Excel, который я хотел, чтобы выводперейти в массив. я бегу код комбинации, который будет выводить в массив.

Option Explicit

Private c As Integer

Sub test_print_nCr()

Dim x As Integer
Dim StartRow As Integer
Dim Returned_Value As Variant

    print_nCr 2, 2, Cells(1, 1)

End Sub

Function print_nCr(n As Integer, r As Integer, p As Range)
  c = 1
  print_nCr = internal_print_nCr(n, r, p, 1, 1)
End Function


Private Function internal_print_nCr(n As Integer, r As Integer, ByVal p As Range, Optional i As Integer, Optional l As Integer) As Variant

  ' n is the number of items we are choosing from
  ' r is the number of items to choose
  ' p is the upper corner of the output range
  ' i is the minimum item we are allowed to pick
  ' l is how many levels we are in to the choosing
  ' c is the complete set we are working on

  If n < 1 Or r > n Or r < 0 Then Err.Raise 1
  If i < 1 Then i = 1
  If l < 1 Then l = 1
  If c < 1 Then c = 1
  If r = 0 Then
    p = 1
    Exit Function
  End If

  Dim x As Integer
  Dim y As Integer

  ReDim Arr_Offset_Replacement(0 To (n - r + 1), 0 To n) As Variant

  Arr_Offset_Replacement(0, 0) = ""

  For x = i To n - r + 1
    If r = 1 Then
      If c > 1 Then
        For y = 0 To l - 2
         ' If p.Offset(c - 1, y) = "" Then
          If Arr_Offset_Replacement(c - 1, y) = "" Then
            'p.Offset(c - 1, y) = p.Offset(c - 2, y)
            Arr_Offset_Replacement(c - 1, y) = Arr_Offset_Replacement(c - 2, y)
          End If
        Next y
      End If
      'p.Offset(c - 1, l - 1) = x
      Arr_Offset_Replacement((c - 1), (l - 1)) = x
      c = c + 1
    Else
      'p.Offset(c - 1, l - 1) = x
      Arr_Offset_Replacement(c - 1, l - 1) = x
      internal_print_nCr n, r - 1, p, x + 1, l + 1
    End If


  Next
    For x = 1 To UBound(Arr_Offset_Replacement, 1)
        For y = 1 To UBound(Arr_Offset_Replacement, 2)
        Cells(x, y) = Arr_Offset_Replacement(x, y)
        Debug.Print Arr_Offset_Replacement(x, y)
        Next
    Next x

End Function
...