有6列数据，每列出n个进行一一组合。

chinjingo

从B列到H列6列数，每列不超过9个数。
如何实现：每列各出n个数(n<4)进行一一组合，列出所有组合。

zhurenmu

Public ihang As Integer
Public ilie As Integer
Public itemp As Integer

Public sh2 As Worksheet




Sub main()
Application.ScreenUpdating = False



Set sh2 = Sheets(2)
Dim icount As Integer
Dim inum As Integer
Dim a(1 To 6) As Integer, b(1 To 6) As Integer

Dim k1%, k2%, k3&, k4%, k5%, k6%
Dim k(1 To 6) As Integer

Dim iout As Integer

iout_lie = 11
iout_hang = 2



For i = 1 To 6
icount = Application.WorksheetFunction.CountA(Range(Cells(3, i + 1), Cells(11, i + 1)))
inum = Sheets(1).Cells(2, i + 1).Value
b(i) = inum
a(i) = Sheets(1).Cells(12, i + 1)

' Debug.Print icount
'Debug.Print inum


ihang = 1
ilie = 1 + 4 * (i - 1)
If inum > 0 Then
mycomb 1, icount, inum

End If
Next i






  For k1 = 1 To a(1)
     For k2 = 1 To a(2)
         For k3 = 1 To a(3)
         
             For k4 = 1 To a(4)
              For k5 = 1 To a(5)
               For k6 = 1 To a(6)
               
               
               
               
               
               
                temp = iout_lie
               
                For i = 1 To 6
                  If (b(i) > 0) Then
                  For j = 1 To b(i)
                  k(1) = k1
                  k(2) = k2
                  k(3) = k3
                  k(4) = k4
                  k(5) = k5
                  k(6) = k6
                  
                    Sheets(1).Cells(iout_hang, iout_lie).Value = Sheets(1).Cells(sh2.Cells(k(i), 4 * (i - 1) + j) + 2, i + 1)
                    iout_lie = iout_lie + 1
                    Next j
                  End If
               
                Next i
                  
                iout_lie = temp
               
                If (iout_hang = 65536) Then
                  iout_hang = 0
                  iout_lie = iout_lie + 16
                End If
               
               
                iout_hang = iout_hang + 1
               
               
               
               
               Next k6
                Next k5
            Next k4
        Next k3
    Next k2
Next k1
        
               


'输出







Application.ScreenUpdating = True
MsgBox "计算完成！！！"

   
End Sub

Function mycomb(ByVal iStart As Integer, iEnd As Integer, Num As Integer, Optional Str As String)
    Dim i As Integer, j As Integer
   
    If Num = 0 Then
     itemp = ilie
        For j = 1 To Len(Str)
      
        sh2.Cells(ihang, ilie).Value = Mid(Str, j, 1)
        ilie = ilie + 1
        Next j
        ihang = ihang + 1
        ilie = itemp
        
        
        
    Else
        For i = iStart To iEnd
            DoEvents

            mycomb i + 1, iEnd, Num - 1, Str & i

        Next
    End If
End Function

zljkd007

第一：无附件；第二：题意不明；第三：楼主悬赏500财富，本身财富不到114。

chinjingo

我也纳闷，悬赏帖一出就扣了500财富，我估摸着是打进了一个类似“支付宝”之类的东西，以防反悔。
知道真相的可否出来解释一下。

zhurenmu

哈哈  我来领取啦   程序我再改改~~