VBA字典改错兼提速

雄鹰2013

laoau138 发表于 2016-9-26 21:27
不知道你这两句话的含意

这是附件

pengyx

雄鹰2013 发表于 2016-9-27 21:22
感觉有2275行，楼主可以看看
运行速度在5秒左右

For ii = 1 To UBound(ar)
         dd.RemoveAll
         n = 0
         br = Split(Split(ar(ii), "/")(0), ",")
         cr = Split(Split(ar(ii), "/")(1), "~")
         For k = 0 To UBound(cr)
             dd(CInt(cr(k))) = ""
         Next k
这个为什么要放在ARR中去循环？放在外面速度好些。没别的意思只是没懂

pengyx

析分条件是固定的，没必要每循环一次就做一次析分，速度应不超过3S

laoau138

雄鹰2013 发表于 2016-9-27 21:23
这是附件

只要不改变单元格S15:S22条件，结果正确U:Z列只有993行,多一行或者少一行都错误

这两个正确：zhjlgaojuan 这个数组最慢，  excelvlookup这个字典最快

这两个错误: 雄鹰， grf1973

目前excelvlookup最快1.5秒  ,  据excelvlookup大神说，不用数组最快0.7秒，

继续努力吧，雄鹰大侠你在看看错在哪里，再加速


Sub excelvlookup()
ti = Timer
ar = Range("a15:f" & [f65535].End(xlUp).Row)
br = Range("s15:s" & [s65535].End(xlUp).Row)
ReDim cr(1 To UBound(ar), 1 To 6)
ReDim arr(1 To UBound(br), 1 To 3)
For j = 1 To UBound(br)
    t1 = Split(Split(br(j, 1), "/")(0), ",")
    arr(j, 1) = t1
    If Len(Split(br(j, 1), "/")(1)) > 1 Then
        t = Split(Split(br(j, 1), "/")(1), "~")
        tx = Val(t(0))
        td = Val(t(UBound(t)))
    Else
        tx = Val(Split(br(j, 1), "/")(1))
        td = Val(Split(br(j, 1), "/")(1))
    End If
    arr(j, 2) = tx: arr(j, 3) = td
Next
'析分条件
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(ar)
    d.RemoveAll
    For j = 1 To UBound(ar, 2)
        d(Val(ar(i, j))) = 0
    Next
'写入字典
    fa = True
  '没置判断条件
    For j = 1 To UBound(br)
        s = 0
        For Each x In arr(j, 1)
            r = Val(x)
            If d(r) <> "" Then
                s = s + 1
            End If
        Next
        If s < arr(j, 2) Or s > arr(j, 3) Then fa = False: Exit For
    Next
   '分析数据是否满足
    If fa = True Then
        n = n + 1
        For k = 1 To 6
            cr(n, k) = ar(i, k)
        Next
    End If
'满足条件的写入数组
Next
[U15:Z65535].ClearContents
If n > 0 Then [U15].Resize(n, 6) = cr
MsgBox Timer - ti
'写入表格，统计耗时
End Sub

如果不用字典，耗时只要0.7秒左右。

laoau138

pengyx 发表于 2016-9-27 22:07
析分条件是固定的，没必要每循环一次就做一次析分，速度应不超过3S

不用字典最快0.7秒，目前这个字典1.5秒

你快点来超越吧

laoau138

雄鹰2013 发表于 2016-9-27 21:23
这是附件

减少A:F列数据，减少S列条件，

grf1973这个完全没有输出，不知道错在哪里

化简一下题目,发现雄鹰这个错误

条件一: 01,05/0~1.......代表1,5这2个数字 去匹配A:F列那行是含有0个,或者含有1个的行输出,

含有2个的行被过滤不输出.........(含有2个不输出代表，1和5不能在同一行)........所以0~1属于或关系

条件二: 07,08,09/2~3......代表7,8,9这3个数字 去匹配A:F列那行是含有2个,或者含有3个的行输出,

含有0个，或者含有1个的行被过滤不输出........(含有0个代表在一行中7，8，9一个都没有，

含有1个代表一中含有7，8，9任意一个).....................................所以2~3属于或关系

如此类推       当A:F列那行同时满足S列这2个条件................所以条件一，条件二，属于与关系

单击U列"过滤按钮"正确结果105行 从U:Z列15行开始输出"过滤结果"

雄鹰2013

pengyx 发表于 2016-9-27 22:03
For ii = 1 To UBound(ar)
         dd.RemoveAll
         n = 0

这个题也没认真思考，谢谢提醒

laoau138

雄鹰2013 发表于 2016-9-27 21:23
这是附件

大侠，这一条如何做

VBA比较多个条件满足才能提取

http://www.excelpx.com/thread-424447-1-1.html



大侠，这一条如何做

VBA比较多个条件满足才能提取

http://www.excelpx.com/thread-424447-1-1.html

雄鹰2013

laoau138 发表于 2016-9-27 22:38
只要不改变单元格S15:S22条件，结果正确U:Z列只有993行,多一行或者少一行都错误

这两个正确：zhjlgaoj ...

Sub 测试()
Dim arr, brr, ar, br, cr
Set d = CreateObject("scripting.dictionary") '存放数据源中的每一行数据
Set dd = CreateObject("scripting.dictionary")
t = Timer
With Sheets("测试")
      .Range("t15:z" & Cells(Rows.Count, 20).End(xlUp).Row) = "" '清空要存放的数据
      arr = .Range("a15:f" & Cells(Rows.Count, 6).End(xlUp).Row) '数据源
      ar = Application.Transpose(.Range("s15:s" & .Cells(Rows.Count, 19).End(xlUp).Row)) '待过滤的条件
      ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
      For i = 1 To UBound(ar)
          Set dd(i) = CreateObject("scripting.dictionary")
          cr = Split(Split(ar(i), "/")(1), "~") '待过滤的条件
          For k = 0 To UBound(cr)
              p = CInt(cr(k))
              dd(i)(p) = "" '将每个过滤条件装入字典
          Next k
      Next i
      For i = 1 To UBound(arr)
          d.RemoveAll
          m = 0
          For j = 1 To UBound(arr, 2)
              p = CInt(arr(i, j))
              d(p) = "" '将指定的数据装入字典中
          Next j
             For ii = 1 To UBound(ar)
                 n = 0
                 br = Split(Split(ar(ii), "/")(0), ",") '待过滤的数据
                 For iii = 0 To UBound(br)
                     p = CInt(br(iii))
                     If d.exists(p) Then n = n + 1
                 Next iii
                 If dd(ii).exists(n) Then
                    m = m + 1
                    GoTo 100
                 End If
                 If m <> ii Then GoTo 10
               
100:         Next ii
             If m = UBound(ar) Then
                s = s + 1
                For j = 1 To UBound(arr, 2)
                    brr(s, 1) = s
                    brr(s, j + 1) = arr(i, j)
                Next j
             End If
10: Next i
    MsgBox Timer - t
   .[t15].Resize(s, UBound(brr, 2)) = brr
End With
End Sub

雄鹰2013

雄鹰2013 发表于 2016-9-30 13:30
Sub 测试()
Dim arr, brr, ar, br, cr
Set d = CreateObject("scripting.dictionary") '存放数据源中 ...

速度3s左右