谢谢各位老师的解答。

crazy0qwer

excelcpeh 发表于 2018-7-26 08:43
感激老师的解答！！！
点代码出现类型不匹配。

抱歉，忘记考虑输入单个数了。

极速提取4.rar (220.63 KB, 下载次数: 10)

2018-7-26 08:58 上传

点击文件名下载附件

lsdongjh

极速提取.rar (240.08 KB, 下载次数: 10)

2018-7-26 11:23 上传

点击文件名下载附件

crazy0qwer

crazy0qwer 发表于 2018-7-26 08:59
抱歉，忘记考虑输入单个数了。

扩大存放结果数据的数组行数，这样即使全部数据满足条件也不会报错。

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:E" & Sheets("SHEET1").Range("D" & Rows.Count).End(xlUp).Row)     '输入数据
   
8.     Lrow = UBound(Arr)
   
9.     Lcol = UBound(Arr, 2)
   
10.     ReDim Drr(1 To 1000, 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(1000, Lcol - 59).NumberFormatLocal = "@"
    
52.     Sheets("SHEET2").Range("B1").Resize(1000, Lcol - 59) = Drr
    
53.     Sheets("SHEET2").Activate
    
54.     MsgBox Timer - t
    
55. End Sub

复制代码

一把小刀闯天下

crazy0qwer 发表于 2018-7-26 23:18
扩大存放结果数据的数组行数，这样即使全部数据满足条件也不会报错。

'有序的用纯数组来处理效率确实非常高，学习了

'原来D列中的条件为或关系，我一直以为每个条件都是独立的，晕

'加了个字典试了一下，你这B列中有"746"这个数是否有问题，其他列也都多了一个数

crazy0qwer

一把小刀闯天下 发表于 2018-7-27 07:31
'有序的用纯数组来处理效率确实非常高，学习了

'原来D列中的条件为或关系，我一直以为每个条件都是独 ...

746 这个数在原数据中没有，也就是出现次数为 0 次。
我代码没有做判断，D列有空的会被当做0。
修改如下：
极速提取5.rar (213.95 KB, 下载次数: 20)

2018-7-27 10:44 上传

点击文件名下载附件

其实速度快的主要原因并不是排序问题。
说说思路吧：楼主的分组规则是 1-60 2-61 ，可以看到其实第一第二组都包含了2-60列的数据，所以没有必要每算一组就再去算这些重复的。

我的代码：
1、首先计算出第一组1-60列的数据并得出第一组结果
2、计算第二组的时候，使用第一组的结果，并减去第 1 列数据，再加上第 61 列数据，即可得到第二组2-61的结果。
3、第三组同理，使用第二组计算结果，减去第2列数据，加上第62列数据。。。。。
其他组同理就可以了。

结果就是我的代码对于源数据的每列，只循环了两次(一次减，一次加)。这个是速度快的主要原因。

excelcpeh

crazy0qwer 发表于 2018-7-27 10:52
746 这个数在原数据中没有，也就是出现次数为 0 次。
我代码没有做判断，D列有空的会被当做0。
修改如 ...

谢谢老师的耐心解答~

一把小刀闯天下

crazy0qwer 发表于 2018-7-27 10:52
746 这个数在原数据中没有，也就是出现次数为 0 次。
我代码没有做判断，D列有空的会被当做0。
修改如 ...

'嗯，想法非常好，感谢解惑

'按你的方法写了一个，只是加了一个字典。比原来使用双字典快了8倍

Option Explicit

Sub test()
  Dim arr, brr, dic, dt, i As Long, j As Long, m As Long
  dt = Timer
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("d1:d" & .Cells(Rows.Count, "d").End(xlUp).Row + 1)
    brr = .[g1].CurrentRegion
  End With
  ReDim crr(1 To 999, 1 To UBound(brr, 2) - 59) As String
  ReDim drr(999) As Long
  dic(arr(1, 1)) = vbNullString
  For i = 2 To UBound(arr, 1) - 1
    If Len(arr(i, 1)) And IsNumeric(arr(i, 1)) Then dic(arr(i, 1)) = vbNullString
  Next
  For j = 1 To 60
    For i = 1 To UBound(brr, 1)
      If Len(brr(i, j)) = 0 Then Exit For
      drr(brr(i, j)) = drr(brr(i, j)) + 1
  Next i, j
  m = 0
  For i = 0 To UBound(drr)
    If dic.exists(drr(i)) Then m = m + 1: crr(m, 1) = Format(i, "000")
  Next
  For j = 2 To UBound(brr, 2) - 59
    For i = 1 To UBound(brr, 1)
      If Len(brr(i, j - 1)) Then drr(brr(i, j - 1)) = drr(brr(i, j - 1)) - 1
      If Len(brr(i, j + 59)) Then drr(brr(i, j + 59)) = drr(brr(i, j + 59)) + 1
      If Len(brr(i, j - 1)) = 0 And Len(brr(i, j + 59)) = 0 Then Exit For
    Next
    m = 0
    For i = 0 To UBound(drr)
      If dic.exists(drr(i)) Then m = m + 1: crr(m, j) = Format(i, "000")
    Next
  Next
  With Sheets("结果").[b1]
    .Resize(Rows.Count, UBound(crr, 2) + 2).ClearContents
    .Resize(UBound(crr, 1), UBound(crr, 2)) = crr
  End With
  MsgBox Timer - dt
End Sub