[已解决]排列出所有后面数比前面数大的所有组合

sanpiao

排列出所有后面数比前面数大的所有组合

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-6-28 15:43

sanpiao 发表于 2021-6-28 15:28
第一位N列为0时应是

新增紅色部份

Dim a, ar, g(6), n(1 To 6), m, r
Sub demo()
   [ac1:ah1000] = ""
   r = 0
   a = [n1].CurrentRegion
   For i = 1 To UBound(a)
      g(1) = IIf(a(i, 1) > 0, 0, 1)
      For j = 2 To 6
         g(j) = g(j - 1)
         If a(i, j) <= a(i, j - 1) Then g(j) = g(j) + 1
      Next
      m = g(6): ar = i: com 1, 0
   Next
End Sub
Sub com(ByVal k, ByVal i)
   If k > 6 Then
      r = r + 1: Cells(r, "ac").Resize(1, 6) = n
      Exit Sub
   End If
   If g(k) > g(k - 1) Then i = i + 1
   For i = i To 3 - m + g(k)
      n(k) = i * 10 + a(ar, k)
      com k + 1, i
   Next
End Sub

跳转到最佳答案楼层

心正意诚身修

没看懂。

sanpiao

心正意诚身修 发表于 2021-6-28 13:24
没看懂。

您 好！每个数分别加10，20，30符合后面的数比前面的数大的组合排列出来

cutecpu

Dim a, ar, g(6), n(1 To 6), m, r
Sub demo()
   [ac1:ah1000] = ""
   a = [n1].CurrentRegion
   For i = 1 To UBound(a)
      For j = 2 To 6
         g(j) = g(j - 1)
         If a(i, j) < a(i, j - 1) Then g(j) = g(j) + 1
      Next
      m = g(6): ar = i: com 1, 0
   Next
End Sub
Sub com(ByVal k, ByVal i)
   If k > 6 Then
      r = r + 1: Cells(r, "ac").Resize(1, 6) = n
      Exit Sub
   End If
   If g(k) > g(k - 1) Then i = i + 1
   For i = i To 3 - m + g(k)
      n(k) = i * 10 + a(ar, k)
      com k + 1, i
   Next
End Sub

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-6-28 14:38
Dim a, ar, g(6), n(1 To 6), m, r
Sub demo()
   [ac1:ah1000] = ""

感谢老师！补充一下：每个数分别加10，20，30符合后面的数比前面的数大的组合排列出来
两个小问题：                          
1、改变N：S数据，组合结果不从AC1写入。
2、第一位N列为0时应该出现10或20、30.排列结果只出现后面数比前面数大，没有想等的结果。

cutecpu

sanpiao 发表于 2021-6-28 15:03
感谢老师！补充一下：每个数分别加10，20，30符合后面的数比前面的数大的组合排列出来
两个小问题：     ...

您好，

1、改变N：S数据，组合结果不从AC1写入。

這句是什麼意思

2. 正確答案是如圖這樣嗎？

sanpiao

cutecpu 发表于 2021-6-28 15:13
您好，

1、改变N：S数据，组合结果不从AC1写入。

从下面单元格写入结果

cutecpu

sanpiao 发表于 2021-6-28 15:21
从下面单元格写入结果

新增、修改藍色部份

Dim a, ar, g(6), n(1 To 6), m, r
Sub demo()
   [ac1:ah1000] = ""
   r = 0
   a = [n1].CurrentRegion
   For i = 1 To UBound(a)
      For j = 2 To 6
         g(j) = g(j - 1)
         If a(i, j) <= a(i, j - 1) Then g(j) = g(j) + 1
      Next
      m = g(6): ar = i: com 1, 0
   Next
End Sub
Sub com(ByVal k, ByVal i)
   If k > 6 Then
      r = r + 1: Cells(r, "ac").Resize(1, 6) = n
      Exit Sub
   End If
   If g(k) > g(k - 1) Then i = i + 1
   For i = i To 3 - m + g(k)
      n(k) = i * 10 + a(ar, k)
      com k + 1, i
   Next
End Sub

sanpiao

cutecpu 发表于 2021-6-28 15:25
新增、修改藍色部份

Dim a, ar, g(6), n(1 To 6), m, r

第一位N列为0时应是

cutecpu

sanpiao 发表于 2021-6-28 15:28
第一位N列为0时应是

新增紅色部份

Dim a, ar, g(6), n(1 To 6), m, r
Sub demo()
   [ac1:ah1000] = ""
   r = 0
   a = [n1].CurrentRegion
   For i = 1 To UBound(a)
      g(1) = IIf(a(i, 1) > 0, 0, 1)
      For j = 2 To 6
         g(j) = g(j - 1)
         If a(i, j) <= a(i, j - 1) Then g(j) = g(j) + 1
      Next
      m = g(6): ar = i: com 1, 0
   Next
End Sub
Sub com(ByVal k, ByVal i)
   If k > 6 Then
      r = r + 1: Cells(r, "ac").Resize(1, 6) = n
      Exit Sub
   End If
   If g(k) > g(k - 1) Then i = i + 1
   For i = i To 3 - m + g(k)
      n(k) = i * 10 + a(ar, k)
      com k + 1, i
   Next
End Sub