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

三票

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

上示例中，交叉出的结果。在组合中行、列出几个数在组合结果中就出现几个，在同一组合结果中只要有数据出现的行列中的数据按出现个数同时组合出现

DevilW

1. Sub test()
   
2.     Dim br(1 To 10000, 1 To 6), ar
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = Join(Application.Transpose([d3:d8]), "") '行规则
   
5.     c = Join(Application.Transpose(Application.Transpose([e2:j2])), "") '列规则
   
6.     ReDim ar(Application.Count([e3:j8]))
   
7.     For Each a In [e3:j8] '取有效数据
   
8.         If a <> "" Then n = n + 1: ar(n) = a
   
9.     Next
   
10.     For s1 = 1 To n - 5
    
11.         For s2 = s1 + 1 To n - 4
    
12.             For s3 = s2 + 1 To n - 3
    
13.                 For s4 = s3 + 1 To n - 2
    
14.                     For s5 = s4 + 1 To n - 1
    
15.                         For s6 = s5 + 1 To n
    
16.                             s = Array(0, ar(s1), ar(s2), ar(s3), ar(s4), ar(s5), ar(s6)) '取得组合
    
17.                             For i = 1 To 6
    
18.                                 rx = s(i) / 6: cx = s(i) Mod 6
    
19.                                 If rx = Int(rx) Then ry = rx Else ry = Int(rx) + 1 '取每数行信息
    
20.                                 If cx Mod 6 Then cy = cx Mod 6 Else cy = 6 '取每数列信息
    
21.                                 d(ry) = d(ry) + 1: d(cy + 6) = d(cy + 6) + 1 '字典记录行列信息
    
22.                             Next
    
23.                             For i = 1 To 6
    
24.                                 rs = rs & Val(d(i)): cs = cs & Val(d(i + 6)) '行列信息排列
    
25.                             Next
    
26.                             d.RemoveAll
    
27.                             If r = rs And c = cs Then '行列规则与行列信息相比较
    
28.                                 x = x + 1
    
29.                                 For i = 1 To 6
    
30.                                     br(x, i) = s(i)
    
31.                                 Next
    
32.                             End If
    
33.                             rs = "": cs = ""
    
34.     Next s6, s5, s4, s3, s2, s1
    
35.     [l17].Resize(x, 6) = br
    
36. End Sub

复制代码

DevilW

代码审核，先放图

三票

DevilW 发表于 2021-3-10 00:01
代码审核，先放图

非常感谢您的帮助！！期待您上传附件

lmgz007

有难度，如果数字位数也变的话，更加麻烦

一把小刀闯天下

'6个数共有240个组合，[e2:j2]和数为6，按条件只能组合为6个数，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, k, m, n, cnt, s
  arr = [d2:j8].Value
  ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2)), pos(1 To 3, 1 To UBound(arr, 2))
  For j = 2 To UBound(arr, 2)
    If arr(1, j) > 0 Then
      m = 0: n = n + 1
      For i = 2 To UBound(arr, 1)
        If arr(i, 1) > 0 And Len(arr(i, j)) > 0 Then
          m = m + 1
          brr(m, n) = arr(i, j)
        End If
      Next
      pos(1, n) = arr(1, j): pos(2, n) = m
    End If
  Next
  ReDim arr(1 To 10 ^ 3, 1 To n)
  cnt = 1
  For i = 1 To n
    m = 0
    Call comb(brr, arr, i, pos(1, i), pos(2, i), m)
    pos(1, i) = m: pos(2, i) = 1: cnt = cnt * m
  Next
  ReDim brr(1 To cnt, 1 To 1) As String
  For i = 1 To UBound(brr, 1)
    For j = 1 To n
      s = s & arr(pos(2, j), j)
    Next
    brr(i, 1) = Mid(s, 2): s = vbNullString
    If pos(2, n) < pos(1, n) Then
      pos(2, n) = pos(2, n) + 1
    Else
      For j = n - 1 To 1 Step -1
        If pos(2, j) < pos(1, j) Then
          pos(2, j) = pos(2, j) + 1
          For k = j + 1 To n
            pos(2, k) = 1
          Next
          Exit For
        End If
      Next
    End If
  Next
  [s3].Resize(UBound(brr, 1)) = brr
End Sub

Function comb(arr, brr, p, a, b, m)
  Dim i, j, n
  ReDim crr(1 To UBound(brr, 1), 1 To 2)
  crr(2, 1) = "," & arr(1, p)
  crr(2, 2) = 1: n = 2
  If crr(2, 2) = a Then m = m + 1: brr(m, p) = "," & arr(1, p)
  For i = 2 To b
    For j = n + 1 To 2 * n
      crr(j, 1) = crr(j - n, 1) & "," & arr(i, p)
      crr(j, 2) = crr(j - n, 2) + 1
      If crr(j, 2) = a Then
        m = m + 1: brr(m, p) = crr(j, 1)
      End If
    Next
    n = n * 2
  Next
End Function

一把小刀闯天下

'你这还有行限定，加了个字典处理了一下，输出结果确实为12个，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, k, m, n, cnt, s, t, dic, key, flag As Boolean
  Set dic = CreateObject("scripting.dictionary")
  arr = [d2:j8].Value
  ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2)), pos(1 To 3, 1 To UBound(arr, 2))
  For j = 2 To UBound(arr, 2)
    If arr(1, j) > 0 Then
      m = 0: n = n + 1
      For i = 2 To UBound(arr, 1)
        If arr(i, 1) > 0 And Len(arr(i, j)) > 0 Then
          m = m + 1
          brr(m, n) = arr(i, j)
        End If
      Next
      pos(1, n) = arr(1, j): pos(2, n) = m
    End If
  Next
  For i = 2 To UBound(arr, 1)
    If arr(i, 1) > 0 Then
      For j = 2 To UBound(arr, 2)
        If arr(1, j) > 0 Then
          s = s & "," & arr(i, j)
        End If
      Next
      dic(s) = arr(i, 1): s = vbNullString
    End If
  Next
  ReDim arr(1 To 10 ^ 3, 1 To n)
  cnt = 1
  For i = 1 To n
    m = 0
    Call comb(brr, arr, i, pos(1, i), pos(2, i), m)
    pos(1, i) = m: pos(2, i) = 1: cnt = cnt * m
  Next
  ReDim brr(1 To cnt, 1 To 1) As String
  cnt = 0
  For i = 1 To UBound(brr, 1)
    For j = 1 To n
      s = s & arr(pos(2, j), j)
    Next
    s = s & ",": flag = True
    For Each key In dic.keys
      t = Split(key, ","): m = 0
      For j = 1 To UBound(t)
        If InStr(s, "," & t(j) & ",") Then m = m + 1
        If m > dic(key) Then Exit For
      Next
      If m <> dic(key) Then flag = False: Exit For
    Next
    If flag Then
      cnt = cnt + 1
      brr(cnt, 1) = Mid(s, 2)
    End If
    s = vbNullString
    If pos(2, n) < pos(1, n) Then
      pos(2, n) = pos(2, n) + 1
    Else
      For j = n - 1 To 1 Step -1
        If pos(2, j) < pos(1, j) Then
          pos(2, j) = pos(2, j) + 1
          For k = j + 1 To n
            pos(2, k) = 1
          Next
          Exit For
        End If
      Next
    End If
  Next
  With [s3]
    .Resize(UBound(brr, 1)).ClearContents
    If cnt > 0 Then .Resize(cnt) = brr
  End With
End Sub

Function comb(arr, brr, p, a, b, m)
  Dim i, j, n
  ReDim crr(1 To UBound(brr, 1), 1 To 2)
  crr(2, 1) = "," & arr(1, p)
  crr(2, 2) = 1: n = 2
  If crr(2, 2) = a Then m = m + 1: brr(m, p) = "," & arr(1, p)
  For i = 2 To b
    For j = n + 1 To 2 * n
      crr(j, 1) = crr(j - n, 1) & "," & arr(i, p)
      crr(j, 2) = crr(j - n, 2) + 1
      If crr(j, 2) = a Then
        m = m + 1: brr(m, p) = crr(j, 1)
      End If
    Next
    n = n * 2
  Next
End Function

三票

一把小刀闯天下 发表于 2021-3-17 15:40
'你这还有行限定，加了个字典处理了一下，输出结果确实为12个，，，

Option Explicit

老师您好，您看一下这个问题能解决吗？

一把小刀闯天下

三票 发表于 2021-4-22 12:38
老师您好，您看一下这个问题能解决吗？

天书系列，看看有没有神仙飘过的，，，