在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的方法來做到這一點的工作簿。