[已解决]根据行列数据出现个数组合数据

sanpiao

根据行列数据出现个数组合数据

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-3-30 16:03

sanpiao 发表于 2021-3-30 15:45
说明在附件中，您看一下

Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:D10"): y = Range("E2:N2"): arr = Range("E3:N10")
   sumx = Application.Sum(x): ReDim v(1 To sumx)
   r = 3
   Call com(1, 1, 1)
End Sub
Sub com(n As Integer, k As Integer, c As Integer)
   If n > UBound(x) Then
      Cells(r, "Q").Resize(1, sumx) = v
      r = r + 1
      Exit Sub
   End If
   If x(n, 1) = 0 Or c > x(n, 1) Then
      Call com(n + 1, 1, 1)
      Exit Sub
   End If
   For i = k To UBound(y, 2) - x(n, 1) + c
      If y(1, i) > 0 And arr(n, i) Then
         y(1, i) = y(1, i) - 1
         m = m + 1
         v(m) = arr(n, i)
         Call com(n, i + 1, c + 1)
         m = m - 1
         y(1, i) = y(1, i) + 1
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

大灰狼1976

抱歉，做的时候没有充分理解你的意思，时间有限，懒得改了，仅作为启发。
现在输出的是以逗号分隔的全排列，而非以行列标数据取数，不喜勿喷。

sanpiao

大灰狼1976 发表于 2021-3-9 21:07
抱歉，做的时候没有充分理解你的意思，时间有限，懒得改了，仅作为启发。
现在输出的是以逗号分隔的全排列 ...

非常感谢您的帮助！！您如果有时间请您按行列标数据取数做一下，输出结果不是以逗号分开的就太完美了！！！期待您的再次帮助（在组合中，行、列出几个数在组合结果中就出现几个，在同一组合结果中只要有数据出现的，行、列  中的数据按出现个数同时组合出现）

cutecpu

Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:D8"): y = Range("E2:J2"): arr = Range("E3:J8")
   sumx = Application.Sum(x): ReDim v(1 To sumx)
   r = 3
   Call com(1, 1, 1)
End Sub
Sub com(n As Integer, k As Integer, c As Integer)
   If n > 6 Then
      Cells(r, "L").Resize(1, sumx) = v
      r = r + 1
      Exit Sub
   End If
   If x(n, 1) = 0 Or c > x(n, 1) Then
      Call com(n + 1, 1, 1)
      Exit Sub
   End If
   For i = k To 6 - x(n, 1) + c
      If y(1, i) > 0 And arr(n, i) Then
         y(1, i) = y(1, i) - 1
         m = m + 1
         v(m) = arr(n, i)
         Call com(n, i + 1, c + 1)
         m = m - 1
         y(1, i) = y(1, i) + 1
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-3-10 16:32
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:D8"): y = Range("E2:J2"): arr = Range("E3 ...

太强大了，非常感谢！！！

sanpiao

cutecpu 发表于 2021-3-10 16:32
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:D8"): y = Range("E2:J2"): arr = Range("E3 ...

行增加到8行，列增加到10列。肯请前辈改一下代码！

cutecpu

sanpiao 发表于 2021-3-30 10:05
行增加到8行，列增加到10列。肯请前辈改一下代码！

您好，模擬一下答案喔！

sanpiao

cutecpu 发表于 2021-3-30 15:09
您好，模擬一下答案喔！

说明在附件中，您看一下

cutecpu

sanpiao 发表于 2021-3-30 15:45
说明在附件中，您看一下

Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:D10"): y = Range("E2:N2"): arr = Range("E3:N10")
   sumx = Application.Sum(x): ReDim v(1 To sumx)
   r = 3
   Call com(1, 1, 1)
End Sub
Sub com(n As Integer, k As Integer, c As Integer)
   If n > UBound(x) Then
      Cells(r, "Q").Resize(1, sumx) = v
      r = r + 1
      Exit Sub
   End If
   If x(n, 1) = 0 Or c > x(n, 1) Then
      Call com(n + 1, 1, 1)
      Exit Sub
   End If
   For i = k To UBound(y, 2) - x(n, 1) + c
      If y(1, i) > 0 And arr(n, i) Then
         y(1, i) = y(1, i) - 1
         m = m + 1
         v(m) = arr(n, i)
         Call com(n, i + 1, c + 1)
         m = m - 1
         y(1, i) = y(1, i) + 1
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-3-30 16:03
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:D10"): y = Range("E2:N2"): arr = Range( ...

向您学习！感谢您再次帮助！！