列出组合函数

zhugaungchao · 发表于 2020-9-12 00:03

请求大神帮助！
问题：
1，怎么用函数实现B：G列对应的每行6个数，两两组合列在I:W列
2，怎么用函数实现B：G列对应的每行6个数，三三组合列在I:W列
3，怎么用函数实现B：G列对应的每行6个数，四四组合列在I:W列
图中仅以两两组合为例。

gxp1986 · 发表于 2020-9-12 10:01

Sub RunF()
Dim i, ln As Long
ln = Cells(10000, 1).End(xlUp).Row
For i = 1 To ln
Call F2(i)
Call F3(i)
Call F4(i)
Next
End Sub
Function F2(ByVal i As Long)
Dim j, k, l, n
ReDim arr(100)
n = 3
With Sheet1
For j = 2 To 6
For l = n To 7
arr(k) = "'" & .Cells(i, j) & "-" & .Cells(i, l)
k = k + 1
Next
n = n + 1
Next
ReDim Preserve arr(k - 1)
Dim sheetname As String
sheetname = .Cells(i, 1).Value
If 工作表是否存在(sheetname) = False Then
Sheets.Add
Application.ActiveSheet.Name = .Cells(i, 1)
End If
End With
With Sheets(sheetname)
.Cells(1, 1) = sheetname
.Cells(2, 1) = "两两结合"
.Range(.Cells(2, "c"), .Cells(2, k + 2)) = arr
End With
End Function
Function 工作表是否存在(ByVal sname As String) As Boolean
Dim i As Integer
For i = 1 To Sheets.Count
If Sheets(i).Name = sname Then
Bs = True
Exit For
End If
Next
End Function
Function F3(ByVal i As String)
Dim j, k, l, n
ReDim arr(100)
n = 3
With Sheet1
For j = 2 To 5
For l = n To 7
If l + 1 <= 7 Then
arr(k) = "'" & .Cells(i, j) & "-" & .Cells(i, l) & "-" & .Cells(i, l + 1)
k = k + 1
End If
Next
n = n + 1
Next
ReDim Preserve arr(k - 1)
Dim sheetname As String
sheetname = .Cells(i, 1).Value
End With
With Sheets(sheetname)
.Cells(3, 1) = "三三结合"
.Range(.Cells(3, "c"), .Cells(3, k + 2)) = arr
End With
End Function
Function F4(ByVal i As String)
Dim j, k, l, n
ReDim arr(100)
n = 3
With Sheet1
For j = 2 To 4
For l = n To 7
If l + 2 <= 7 Then
arr(k) = "'" & .Cells(i, j) & "-" & .Cells(i, l) & "-" & .Cells(i, l + 1) & "-" & .Cells(i, l + 2)
k = k + 1
End If
Next
n = n + 1
Next
ReDim Preserve arr(k - 1)
Dim sheetname As String
sheetname = .Cells(i, 1).Value
End With
With Sheets(sheetname)
.Cells(4, 1) = "四四结合"
.Range(.Cells(4, "c"), .Cells(4, k + 2)) = arr
End With
End Function

复制代码

zhugaungchao · 发表于 2020-9-12 11:07

gxp1986 发表于 2020-9-12 10:01

非常感谢大佬的赐教，小弟太水，不知道怎么用

zhugaungchao · 发表于 2020-9-12 12:18

zhugaungchao 发表于 2020-9-12 11:07
非常感谢大佬的赐教，小弟太水，不知道怎么用

终于搞出来了，非常感谢大佬，我想把结果放到一个sheet里，设计一个函数，我可以指定几码组合，然后把结果列在对应期号的行里

smiletwo · 发表于 2020-9-12 12:44

Sub ss()
  Dim i, j, k, m, arr, brr
  With Sheets("Sheet5")
arr = .Range("B1:G" & .Cells(Rows.Count, 2).End(3).Row)
ReDim brr(1 To UBound(arr), 1 To .Range("W1").Column - .Range("I1").Column + 1)
For i = 1 To UBound(arr)
   m = 0
   For j = 1 To UBound(arr, 2) - 1
      For k = j + 1 To UBound(arr, 2)
         m = m + 1
         brr(i, m) = arr(i, j) & "-" & arr(i, k)
      Next
   Next
Next
.Range("I1").Resize(UBound(brr), UBound(brr, 2)).NumberFormatLocal = "@"
.Range("I1").Resize(UBound(brr), UBound(brr, 2)) = brr
  End With
End Sub

zhugaungchao · 发表于 2020-9-12 14:12

smiletwo 发表于 2020-9-12 12:44
Sub ss()
Dim i, j, k, m, arr, brr
With Sheets("Sheet5")

非常感谢大神，正是这个意思，强，要是3码组，或4码组合该怎么修改代码呢

yjh_27 · 发表于 2020-9-12 14:14

zhugaungchao 发表于 2020-9-12 12:18
终于搞出来了，非常感谢大佬，我想把结果放到一个sheet里，设计一个函数，我可以指定几码组合，然后把结 ...

n取m 自定义函数随机组合排列分组分配
http://club.excelhome.net/thread-1526867-1-1.html
(出处: ExcelHome技术论坛)

zhugaungchao · 发表于 2020-9-12 14:22

yjh_27 发表于 2020-9-12 14:14
n取m 自定义函数随机组合排列分组分配
http://club.excelhome.net/thread-1526867-1-1.html
(出处 ...

感谢老大，这个好，都是大神级的人物，再次感谢

smiletwo · 发表于 2020-9-12 14:47

zhugaungchao 发表于 2020-9-12 14:12
非常感谢大神，正是这个意思，强，要是3码组，或4码组合该怎么修改代码呢

请写示例。有用请送花

zhugaungchao · 发表于 2020-9-12 14:57

smiletwo 发表于 2020-9-12 14:47
请写示例。有用请送花

附件是3码组合方式，6选3共20种组合方式，和2码组合一样，点击运行便把三三组合的结果列出来了

		自动登录	找回密码
密码			免费注册

列出组合函数

评分

评分