Создание комбинаций в Excel VBA

Question

Я просмотрел весь сайт, пытаясь найти макрос (или функцию), который будет создавать уникальные комбинации из данного списка в соседних столбцах.

Так в основном, у меня есть:

A 1 F1 R1 
B 2 F2 
C  F3 
D 
E 

И я пытаюсь перечислить всю информацию, как (в том же листе и в разных столбцах):

A 1 F1 R1 
A 1 F2 R1 
A 1 F3 R1 
A 2 F1 R1 
A 2 F2 R1 
A 2 F3 R1 
B 1 F1 R1 
B 1 F2 R1 
B 1 F3 R1 
B 2 F1 R1 
B 2 F2 R1 
B 2 F3 R1 
...etc. 

(дополнительный бонус для возможность переключения, где список печатается на листе)

Answer 1

Код для получения всех возможных комбинаций следующим образом:

Option Explicit 

Sub Combinations() 

    Dim ws As Worksheet 
    Set ws = Sheets("Sheet1") 
    Dim a As Range, b As Range, c As Range, d As Range 
    Dim x&, y&, z&, w& 

    For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row 
     Set a = ws.Range("A" & x) 
     For y = 1 To ws.Range("B" & Rows.Count).End(xlUp).Row 
      Set b = ws.Range("B" & y) 
      For z = 1 To ws.Range("C" & Rows.Count).End(xlUp).Row 
       Set c = Range("C" & z) 
       For w = 1 To ws.Range("D" & Rows.Count).End(xlUp).Row 
        Set d = ws.Range("D" & w) 
        Debug.Print a & vbTab & b & vbTab & c & vbTab & d 
        Set d = Nothing 
       Next 
       Set c = Nothing 
      Next 
      Set b = Nothing 
     Next y 
     Set a = Nothing 
    Next x 

End Sub 

и выход

A 1 F1 R1 
A 1 F2 R1 
A 1 F3 R1 
A 2 F1 R1 
A 2 F2 R1 
A 2 F3 R1 
B 1 F1 R1 
B 1 F2 R1 
B 1 F3 R1 
B 2 F1 R1 
B 2 F2 R1 
B 2 F3 R1 
C 1 F1 R1 
C 1 F2 R1 
C 1 F3 R1 
C 2 F1 R1 
C 2 F2 R1 
C 2 F3 R1 
D 1 F1 R1 
D 1 F2 R1 
D 1 F3 R1 
D 2 F1 R1 
D 2 F2 R1 
D 2 F3 R1 
E 1 F1 R1 
E 1 F2 R1 
E 1 F3 R1 
E 2 F1 R1 
E 2 F2 R1 
E 2 F3 R1 

Answer 2

Попробуйте этот код VBA:

Type tArray 
    value As String 
    count As Long 
End Type 

Sub combineAll() 
    Dim sResult(10) As tArray, rRow(10) As Long, str() As String 
    Dim sRow As Long, sCol As Long 
    Dim i As Long, r As Long 
    Dim resRows As Long 
    sRow = 1: sCol = 1: r = 0 

    With ActiveSheet 
     Do 
      rRow(sCol) = 1 
      If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do 
      Do 
       If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do 
       sResult(sCol).value = sResult(sCol).value & Trim(.Cells(sRow, sCol).value) & ";" 
       sResult(sCol).count = sResult(sCol).count + 1 
       sRow = sRow + 1 
      Loop 
      sCol = sCol + 1 
      sRow = 1 
     Loop 

     Do 
      r = r + 1 
      For i = 1 To sCol - 1 
       str = Split(sResult(i).value, ";") 
       .Cells(r, sCol + i).value = str(rRow(i) - 1) 
      Next i 

      For i = sCol - 1 To 1 Step -1 
       If rRow(i) < sResult(i).count Then 
        rRow(i) = rRow(i) + 1 
        Exit For 
       Else 
        rRow(i) = 1 
       End If 
      Next i 

      If rRow(1) >= sResult(1).count Then Exit Do 
     Loop 

    End With 

End Sub 

Answer 3

Там есть книги на https://app.box.com/s/47b28f19d794b25511be с обеими формулировками и VBA на основе методов, чтобы сделать это.