[已解决]求依次增大区间分别对b3开始的b列各单元格的所有数字进行查找的vba程序

grf1973

你另发个帖子，标题写“求提速”，会有一堆算法高手出现的。。。。。

rangevba

grf1973 发表于 2016-4-25 16:38
你另发个帖子，标题写“求提速”，会有一堆算法高手出现的。。。。。

谢谢你！

雄鹰2013

Dim brr, crr, arr(), err(), ar, br, cr, tj1, tj2, x, y, yy, z, a, m
Dim d As Object, i
Sub 练习4() '雄鹰2017.11.8
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
t = Timer
Sheets("题目").Activate
Columns("B:C").Interior.ColorIndex = 0
brr = Range("b3:b" & [b65536].End(3).Row)
crr = Range("c3:c" & [c65536].End(3).Row)
ReDim arr(1 To UBound(crr), 1 To 1)
ReDim err(1 To UBound(crr), 1 To 2)
i = 1
For i = i To UBound(crr) '循环c列
     a = i: yy = 1: y = 1
     Do While i Mod 21
        ty
        If yy = 0 Then i = a + 20: z = a + 20: Exit Do
        i = i + 1
     Loop
     If yy = 1 Then ty
Next i
[g3].Resize(UBound(crr), 3) = ""
[g3].Resize(UBound(crr), 1) = arr
[h3].Resize(m, 2) = err
MsgBox Format(Timer - t, "0.00秒")
z = 0: m = 0
Application.ScreenUpdating = True
End Sub
Sub ty()
    x = Split(crr(i, 1), "=")
    cr = Split(x(1), " ")
    For ii = 0 To UBound(cr)
        d(cr(ii)) = ""
    Next ii
    tj1 = Val(Split(x(0), "-")(0))
    tj2 = Val(Split(x(0), "-")(1))
    If y = 1 Then
       s = Join(Application.Transpose(Range("a3:a" & [b65536].End(3).Row)), ",")
       ar = Split(s, ","): y = 0: s = ""
    Else
       ar = Split(arr(z, 1), ",")
    End If
    For j = 0 To UBound(ar) '循环b列
        br = Split(brr(ar(j), 1), " ")
        For jj = 0 To UBound(br)
            If d.exists(br(jj)) Then n = n + 1
        Next jj
        If n >= tj1 And n <= tj2 Then
           s = s & "," & ar(j)
        End If
        n = 0
    Next j
    If s <> "" Then
       z = z + 1: arr(z, 1) = Mid(s, 2)
       If InStr(arr(z, 1), ",") = 0 Then '只包含一个序号
          m = m + 1
          err(m, 1) = brr(arr(z, 1), 1)
          err(m, 2) = "条件区间: 第" & a & "行至第" & i & "行"
          Cells(arr(z, 1) + 2, 2).Interior.ColorIndex = 2 + m
          Range("c" & a & ":c" & i).Interior.ColorIndex = 2 + m
          d.RemoveAll: s = "": yy = 0
          Exit Sub
       End If
       d.RemoveAll: s = ""
    End If
End Sub