[已解决]原来的问题增加了两个条件：（根据行列数据出现个数组合数据）求代码更改

sanpiao

原来的问题增加了两个条件（根据行列数据出现个数组合数据）求代码更改。在线等

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-4-6 14:14

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

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

xiaoni

我是小白，请问你的模块怎么重命名的呀，我的模块1右键没有重命名

王宪

xiaoni 发表于 2021-4-3 16:40
我是小白，请问你的模块怎么重命名的呀，我的模块1右键没有重命名

属性里面改

cutecpu

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

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-4-6 14:14
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:E10"): y = Range("E2:N3"): arr = Range("E ...

您简直是大神啊！！您看数据都变成6行，6列，每列的前3个数为一部分，后3个数为一部分，每行的前3个为一部分，后3个为一部分，行列数据取数按前、后部取数进行组合。这个代码要在哪里修改呢？

cutecpu

sanpiao 发表于 2021-4-6 21:04
您简直是大神啊！！您看数据都变成6行，6列，每列的前3个数为一部分，后3个数为一部分，每行的前3个为一 ...

Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:E8"): y = Range("E2:J3"): arr = Range("E3:J8")
   For i = 1 To UBound(x)
      x(i, 2) = Cells(i + 2, "k")
   Next
   For i = 1 To UBound(y, 2)
      y(2, i) = Cells(9, i + 4)
   Next
   sumx = Application.Sum(x): ReDim v(1 To sumx)
   r = 3
   Call com(1, 1, 1, 1)
End Sub
Sub com(n As Integer, k As Integer, c As Integer, xx As Integer)
   If n > UBound(x) Then
      Cells(r, "N").Resize(1, sumx) = v
      r = r + 1
      Exit Sub
   End If
   If x(n, xx) = 0 Or c > x(n, xx) Then
      If xx = 1 Then
         Call com(n, 1, 1, 2)
      Else
         Call com(n + 1, 1, 1, 1)
      End If
      Exit Sub
   End If
   s = 0: If xx = 2 Then s = 3
   yy = 1: If n > 3 Then yy = 2
   For i = k To s + 3 - x(n, xx) + c
      If y(yy, i) > 0 And arr(n, i) Then
         y(yy, i) = y(yy, i) - 1
         m = m + 1
         v(m) = arr(n, i)
         Call com(n, i + 1, c + 1, xx)
         m = m - 1
         y(yy, i) = y(yy, i) + 1
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-4-6 22:20
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:E8"): y = Range("E2:J3"): arr = Range(" ...

sanpiao

cutecpu 发表于 2021-4-6 14:14
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:E10"): y = Range("E2:N3"): arr = Range("E ...

根据行列数据出现个数组合数据(新增行列个数条件）请老师看一下代码怎么修改

sanpiao

cutecpu 发表于 2021-4-6 14:14
Dim x, y, arr, v, r, m, sumx
Sub demo()
   x = Range("D3:E10"): y = Range("E2:N3"): arr = Range("E ...

老师，前段时间您给我做的一图表发现点小问题，您给看一下是什么原因

cutecpu

sanpiao 发表于 2021-4-20 20:44
老师，前段时间您给我做的一图表发现点小问题，您给看一下是什么原因

您好，是哪一個組合不該出現？要不要標註一下！