谢谢各位老师的解答。

一把小刀闯天下

excelcpeh 发表于 2018-7-25 18:48
按输入1个数字得到正确答案，那么：
第1次输入31，得到正确答案。
第2次输入21，得到正确答案。

不好意思，我测试的是单个数据。看了一下如果为多个数据确实会有这情况，自己修改后再测试一下。忘了对数组作初始化处理了。

offset = offset + UBound(crr, 2) + 1下面插入一行代码：

ReDim crr(1 To UBound(brr, 1), 1 To UBound(brr, 2) - 60) As String

--------------------------
你这表述如果看懂了问题也就解决了，再好好测试一下，有问题留言

如果觉得满意不要忘了来朵小花哈

excelcpeh

一把小刀闯天下 发表于 2018-7-25 19:01
不好意思，我测试的是单个数据。看了一下如果为多个数据确实会有这情况，自己修改后再测试一下。忘了对数 ...

老师，结果还是有很多列的。

一把小刀闯天下

excelcpeh 发表于 2018-7-25 19:09
老师，结果还是有很多列的。

单个数21列（源数据81列，60列判断，60列是确定的其它都是动态的），就这结果。可以给你作覆盖处理，但是多数据就没有什么意义了，所以每次输出都对列做了右偏置22（其实也是动态的）
--------------
输出结果没有什么毛病，我就按这结果来写的。

excelcpeh

一把小刀闯天下 发表于 2018-7-25 19:25
单个数21列（源数据81列，60列判断，60列是确定的其它都是动态的），就这结果。可以给你作覆盖处理，但是 ...

81列，每列向右取60列一组即：
1-60列为一组
2-61列为一组
3-62列为一组
4-63列为一组
.......
22-81列为一组。所以应该只有22组结果。

一把小刀闯天下

excelcpeh 发表于 2018-7-25 19:30
81列，每列向右取60列一组即：
1-60列为一组
2-61列为一组

单个数是这样的，多个数输出为n*22+1（加了一空列，除了60为定值外其它的我都改为动态的了）

觉得你自己都不知道输出列的数量

--------------------
这论坛的高手非常多，你还是问问他们吧，估计我还是没有理解你的问题，不好意思，准备继续下一站。

excelcpeh

一把小刀闯天下 发表于 2018-7-25 19:36
单个数是这样的，多个数输出为n*22+1（加了一空列，除了60为定值外其它的我都改为动态的了）

觉得你自 ...

无论如何先感谢！虽然还未达要求，这主要是我表述不清晰。谢谢老师的耐心，感激！！！ 祝老师永远开心！

crazy0qwer

excelcpeh 发表于 2018-7-25 19:45
无论如何先感谢！虽然还未达要求，这主要是我表述不清晰。谢谢老师的耐心，感激！！！ 祝老师永远开心！

先说说你想实现的，你看看对不对：
1、60列做一组，1-60 一直到 22-81 。81列共分成 22 组。
2、D列输入条件，例如 输入31 。则要按组找出各组中出现次数为31的数，因为单列不重复，所有出现的次数也可以理解为 有31列中含有这个数，就找出来。
3、如果输入多个数字，比如输入 31 18 ，那只要出现31次或者18次，都找出来合并去重作为该组的输出结果。

下面代码结果和你示例结果有差异，你自己找下是你的错还是我的错。

1. Sub BBB()
   
2.     Dim t
   
3.     Dim Arr, Brr(999) As Long, Crr, Drr
   
4.     Dim I As Long, J As Long, K As Long, N As Long, Lrow As Long, Lcol As Long, M As Long
   
5.     t = Timer
   
6.     Arr = Sheets("SHEET1").Range("G1").CurrentRegion     '源数据
   
7.     Crr = Sheets("SHEET1").Range("D1:D" & Sheets("SHEET1").Range("D" & Rows.Count).End(xlUp).Row)     '输入数据
   
8.     Lrow = UBound(Arr)
   
9.     Lcol = UBound(Arr, 2)
   
10.     ReDim Drr(1 To Lrow, 1 To Lcol - 59)     '结果数据
    
11.     For I = 1 To 60
    
12.         For K = 1 To Lrow
    
13.             If Len(Arr(K, I)) <> 0 Then
    
14.                 M = Val(Arr(K, I))
    
15.                 Brr(M) = Brr(M) + 1
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     For J = 0 To 999
    
20.         For K = 1 To UBound(Crr)
    
21.             If Brr(J) = Crr(K, 1) Then
    
22.                 N = N + 1
    
23.                 Drr(N, 1) = Format(J, "000")
    
24.                 Exit For
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     For I = 1 To Lcol - 60
    
29.         For K = 1 To Lrow
    
30.             If Len(Arr(K, I)) <> 0 Then
    
31.                 M = Val(Arr(K, I))
    
32.                 Brr(M) = Brr(M) - 1
    
33.             End If
    
34.             If Len(Arr(K, I + 60)) <> 0 Then
    
35.                 M = Val(Arr(K, I + 60))
    
36.                 Brr(M) = Brr(M) + 1
    
37.             End If
    
38.         Next
    
39.         N = 0
    
40.         For J = 0 To 999
    
41.             For K = 1 To UBound(Crr)
    
42.                 If Brr(J) = Crr(K, 1) Then
    
43.                     N = N + 1
    
44.                     Drr(N, I + 1) = Format(J, "000")
    
45.                     Exit For
    
46.                 End If
    
47.             Next
    
48.         Next
    
49.     Next
    
50.     Sheets("SHEET2").Cells.Clear
    
51.     Sheets("SHEET2").Range("B1").Resize(Lrow, Lcol - 59).NumberFormatLocal = "@"
    
52.     Sheets("SHEET2").Range("B1").Resize(Lrow, Lcol - 59) = Drr
    
53.     MsgBox Timer - t
    
54. End Sub

复制代码

crazy0qwer

excelcpeh 发表于 2018-7-25 19:45
无论如何先感谢！虽然还未达要求，这主要是我表述不清晰。谢谢老师的耐心，感激！！！ 祝老师永远开心！

上面的代码速度很快。
如果结果有问题，你再试试下面这个代码。

1. Sub AAA()
   
2.     Dim t
   
3.     Dim Arr, Brr() As Long, Crr, Drr
   
4.     Dim I As Long, J As Long, K As Long, N As Long, Lrow As Long, Lcol As Long, M As Long
   
5.     t = Timer
   
6.     Arr = Sheets("SHEET1").Range("G1").CurrentRegion     '源数据
   
7.     Crr = Sheets("SHEET1").Range("D1:D" & Sheets("SHEET1").Range("D" & Rows.Count).End(xlUp).Row)     '输入数据
   
8.     Lrow = UBound(Arr)
   
9.     Lcol = UBound(Arr, 2)
   
10.     ReDim Drr(1 To Lrow, 1 To Lcol - 59)     '结果数据
    
11.     For I = 1 To Lcol - 59
    
12.         ReDim Brr(999)
    
13.         For J = 0 To 59
    
14.             For K = 1 To Lrow
    
15.                 If Len(Arr(K, I + J)) <> 0 Then
    
16.                     M = Val(Arr(K, I + J))
    
17.                     Brr(M) = Brr(M) + 1
    
18.                 End If
    
19.             Next
    
20.         Next
    
21.         N = 0
    
22.         For J = 0 To 999
    
23.             For K = 1 To UBound(Crr)
    
24.                 If Brr(J) = Crr(K, 1) Then
    
25.                     N = N + 1
    
26.                     Drr(N, I) = Format(J, "000")
    
27.                     Exit For
    
28.                 End If
    
29.             Next
    
30.         Next
    
31.     Next
    
32.     Sheets("SHEET2").Cells.Clear
    
33.     Sheets("SHEET2").Range("B1").Resize(Lrow, Lcol - 59).NumberFormatLocal = "@"
    
34.     Sheets("SHEET2").Range("B1").Resize(Lrow, Lcol - 59) = Drr
    
35.     MsgBox Timer - t
    
36. End Sub

复制代码

一把小刀闯天下

excelcpeh 发表于 2018-7-25 19:09
老师，结果还是有很多列的。

'运行前删除工作表"sheet1"[cj1]单元格中的"列数有增加" 说明（因为是动态获取列数的）

'数了一下确实是22列，你把60替换为59，有好几处（用搜索-替换功能）

'81列源数据，1个条件数输出为22列（D列为条件个数），2个22*2+1列，3个22*3+2列,,,。如果输出只要22列你填一个条件数即可，如果多个条件数输出又限定于22列也是可以做到的，那就是只保留最后一个条件数的输出，那还不如只填一个条件数

excelcpeh

crazy0qwer 发表于 2018-7-26 01:09
先说说你想实现的，你看看对不对：
1、60列做一组，1-60 一直到 22-81 。81列共分成 22 组。
2、D列输 ...

感激老师的解答！！！
点代码出现类型不匹配。