谢谢各位老师的解答。

excelcpeh

比较难的提取。能否一步快速得到结果。

一把小刀闯天下

'估计差不多，自己测试一下

Option Explicit

Sub test()
  Dim arr, brr, crr, dic, drr, temp, t As String
  Dim i As Long, j As Long, n As Long
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("d1:d" & .Cells(Rows.Count, "d").End(xlUp).Row)
    brr = .[g1].CurrentRegion
  End With
  ReDim crr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) > 0 Then
      dic.RemoveAll
      For j = 1 To UBound(brr, 1)
        t = brr(j, arr(i, 1)): If Len(t) = 0 Then Exit For
        dic(t) = vbNullString
      Next
      drr = dic.keys: temp = drr
      Call msort(drr, CLng(LBound(drr)), CLng(UBound(drr)), temp)
      n = n + 1
      For j = 0 To UBound(drr): crr(j + 1, n) = drr(j): Next
    End If
  Next
  With Sheets("结果")
    .Cells.ClearContents
    .[b1].Resize(UBound(crr, 1), UBound(crr, 2)) = crr
  End With
End Sub

Function msort(arr, first, last, temp)
  Dim i As Long, j As Long, k  As Long, mid  As Long
  If first <> last Then
    mid = Int((first + last) / 2)
    msort arr, first, mid, temp
    msort arr, mid + 1, last, temp
    i = first: j = mid + 1: k = first
    While i <= mid And j <= last
      If arr(i) <= arr(j) Then
        temp(k) = arr(i): k = k + 1: i = i + 1
      Else
        temp(k) = arr(j): k = k + 1: j = j + 1
      End If
    Wend
    While i <= mid
      temp(k) = arr(i): k = k + 1: i = i + 1
    Wend
    While j <= last
      temp(k) = arr(j): k = k + 1: j = j + 1
    Wend
    For i = first To last: arr(i) = temp(i): Next
  End If
End Function

excelcpeh

一把小刀闯天下 发表于 2018-7-25 09:07
'估计差不多，自己测试一下

Option Explicit

谢谢小刀老师的回复~
结果不对哦。
1.当D列输入1个数字时，代码不能运行。
2.给定的示例数据有81列，每列向右60列为一组。则要有组成81-60=21组数据。
3.比如当输入一个数字31时。第一组60列：31组含有的数据见下面附件。

一把小刀闯天下

excelcpeh 发表于 2018-7-25 11:11
谢谢小刀老师的回复~
结果不对哦。
1.当D列输入1个数字时，代码不能运行。

没看不懂：

“假如只求第一组60列。在D列输入31.则提取第一组中31列含有的数据总共有98个”

98个数怎么来的？没看到有条件约束。如果57列中都出现过的数字那没找到符合条件的 (31-6+59=84，总的数据列为81，也就是当前只能取57列)

觉得看懂一个题目很多时候比写代码费劲的多

microyip

excelcpeh 发表于 2018-7-25 11:11
谢谢小刀老师的回复~
结果不对哦。
1.当D列输入1个数字时，代码不能运行。

连描述都说得不清楚，只有自己懂是什么意思，别人做，当然都是错的啦

excelcpeh

一把小刀闯天下 发表于 2018-7-25 12:20
没看不懂：

“假如只求第一组60列。在D列输入31.则提取第一组中31列含有的数据总共有98个”

抱歉老师。
因给定各列数据本身不含重复。所以98个数据来源可以这样理解:即60列里出现31次的数据集合。比如028它在31列含有，也即出现31次。

microyip

excelcpeh 发表于 2018-7-25 12:40
抱歉老师。
因给定各列数据本身不含重复。所以98个数据来源可以这样理解:即60列里出现31次的数据集合。 ...

你知道自己还是说的自己才明白是什么意思吗？你举的例子，根本就没人明白你说的那些数值来源何处，如何比对

一把小刀闯天下

excelcpeh 发表于 2018-7-25 12:40
抱歉老师。
因给定各列数据本身不含重复。所以98个数据来源可以这样理解:即60列里出现31次的数据集合。 ...

‘进入猜题模式，好像差不多。三楼附件

Option Explicit

Sub test()
  Dim arr, brr, crr, dic, drr, temp, t As String, key, offset
  Dim i As Long, j As Long, k As Long, kk As Long, m As Long
  Set dic = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  With Sheets("sheet1")
    arr = .Range("d1:d" & .Cells(Rows.Count, "d").End(xlUp).Row + 1)
    brr = .[g1].CurrentRegion
  End With
  ReDim crr(1 To UBound(brr, 1), 1 To UBound(brr, 2) - 60) As String
  ReDim drr(1 To UBound(brr, 1)) As String: temp = drr
  Sheets("结果").Cells.ClearContents
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, 1)) > 0 Then
      For j = 1 To UBound(brr, 2) - 60
        dic.RemoveAll: m = 0
        For k = j To j + 59
          For kk = 1 To UBound(brr, 1)
            If Len(brr(kk, k)) = 0 Then Exit For
            dic(brr(kk, k)) = dic(brr(kk, k)) + 1
        Next kk, k
        For Each key In dic.keys
          If dic(key) = arr(i, 1) Then
            m = m + 1: drr(m) = key
          End If
        Next
        If m > 0 Then
          Call msort(drr, CLng(1), CLng(m), temp)
          For k = 1 To m: crr(k, j) = drr(k): Next
        End If
      Next
    End If
    Sheets("结果").[b1].offset(, offset).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
    offset = offset + UBound(crr, 2) + 1
  Next
  Application.ScreenUpdating = True
End Sub

Function msort(arr, first, last, temp)
  Dim i As Long, j As Long, k  As Long, mid  As Long
  If first <> last Then
    mid = Int((first + last) / 2)
    msort arr, first, mid, temp
    msort arr, mid + 1, last, temp
    i = first: j = mid + 1: k = first
    While i <= mid And j <= last
      If arr(i) <= arr(j) Then
        temp(k) = arr(i): k = k + 1: i = i + 1
      Else
        temp(k) = arr(j): k = k + 1: j = j + 1
      End If
    Wend
    While i <= mid
      temp(k) = arr(i): k = k + 1: i = i + 1
    Wend
    While j <= last
      temp(k) = arr(j): k = k + 1: j = j + 1
    Wend
    For i = first To last: arr(i) = temp(i): Next
  End If
End Function

excelcpeh

一把小刀闯天下 发表于 2018-7-25 15:56
‘进入猜题模式，好像差不多。三楼附件

Option Explicit

非常感谢老师的回复。 81列数据，每组向右取60列一组。共21组组数据。所得结果只有21列的。
1.当D列只输入1个数字时，得到正确答案。
2.当D列输入2个数字或更多时，即每组，同时把输入数字出现的个数提取。结果是合并在一列的。

excelcpeh

一把小刀闯天下 发表于 2018-7-25 15:56
‘进入猜题模式，好像差不多。三楼附件

Option Explicit

按输入1个数字得到正确答案，那么：
第1次输入31，得到正确答案。
第2次输入21，得到正确答案。
第3次输入22，得到正确答案。
第4次输入42，得到正确答案。
第5次输入18，得到正确答案。

如果一次同时输入 ：31，21，22，42，18，那么结果就是把每个答案的B-V列对应相加。总数还是21列的。