[已解决]请问：如何计算指定数据在前三列相互包含的汇总？

lygyjt

请教老师：
    B:H是原始数据，A列是序号，不参与计算。
    在J1:P1中输入1~7个指定数据（文本型，数据范围01~99）。

    第1步。按照从上到下顺序，查找原始数据中第1列与指定数据相同的数，将这些相同数去重后，按出现先后，依次放到S列（不重复放置）。
    在原始数据中，把第1列有相同数的行，称为“第1次相同数组”。
    第2步。按照从上到下顺序，查找“第1次相同数组”中第2列与指定数据相同的数，将这些相同数去重后，按出现先后，依次放到此数所在行的第1个数在S列所对应的右边，并附带此数所在行的第1个数。
    比如，第2列中，先后找到了31、02这两个数。而这两个数所在行的第1个数都是13，所以就将（13 31）和（13 02）放在S列13的右边。
    在“第1次相同数组”中，把第2列有相同数的行，称为“第2次相同数组”。
    第3步。 按照从上到下顺序，查找“第2次相同数组”中第3列与指定数据相同的数，将这些相同数去重后，按出现先后，依次放到此数所在行的第1个数在S列所对应的右边，并附带此数所在行的第1、2个数。
    比如，第3列中，找到14这个数。而这个数所在行的第1个数是13，第2个数是31，所以就将（13 31 14）放在S列13的右边。 指定数据在前三列相互包含的汇总.rar (46.25 KB, 下载次数: 3)

2021-4-18 23:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-4-18 23:31

Sub demo()

   Dim b(1 To 99), d(1 To 7)

   For Each Rng In [j1:o1]
      b(Rng.Value) = 1
   Next

   For i = 1 To 7
      Set d(i) = CreateObject("Scripting.Dictionary")
   Next

   bh = Range("b1:h" & [b1].End(xlDown).Row)
   For i = 1 To UBound(bh)
      s = ""
      For j = 1 To 7
         If bh(i, j) = "  " Then Exit For
         If b(bh(i, j)) = 0 Then Exit For
         s = s & bh(i, j): d(j)(s) = 1
      Next
   Next

   Range(Cells(1, "s"), Cells(Cells(Rows.Count, "s").End(xlUp).Row, Sheets(1).UsedRange.Columns.Count)).ClearContents
   For Each Key In d(1).Keys
      r = r + 1: c = 19: Cells(r, c) = Key
      For i = 2 To 7
         For Each s In d(i).Keys
            If s Like Key & "*" Then
               c = c + 1
               For si = 1 To Len(s) Step 2
                  c = c + 1
                  Cells(r, c) = Mid(s, si, 2)
               Next
               d(i).Remove s
            Else
               Exit For
            End If
         Next
      Next
   Next

End Sub


祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Sub demo()

   Dim b(1 To 99), d(1 To 7)

   For Each Rng In [j1:o1]
      b(Rng.Value) = 1
   Next

   For i = 1 To 7
      Set d(i) = CreateObject("Scripting.Dictionary")
   Next

   bh = Range("b1:h" & [b1].End(xlDown).Row)
   For i = 1 To UBound(bh)
      s = ""
      For j = 1 To 7
         If bh(i, j) = "  " Then Exit For
         If b(bh(i, j)) = 0 Then Exit For
         s = s & bh(i, j): d(j)(s) = 1
      Next
   Next

   Range(Cells(1, "s"), Cells(Cells(Rows.Count, "s").End(xlUp).Row, Sheets(1).UsedRange.Columns.Count)).ClearContents
   For Each Key In d(1).Keys
      r = r + 1: c = 19: Cells(r, c) = Key
      For i = 2 To 7
         For Each s In d(i).Keys
            If s Like Key & "*" Then
               c = c + 1
               For si = 1 To Len(s) Step 2
                  c = c + 1
                  Cells(r, c) = Mid(s, si, 2)
               Next
               d(i).Remove s
            Else
               Exit For
            End If
         Next
      Next
   Next

End Sub


祝順心，南無阿彌陀佛！

lygyjt

cutecpu 发表于 2021-4-19 20:09
Sub demo()

   Dim b(1 To 99), d(1 To 7)

没法说谢谢了，版主帮我太多了。