Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 5139|回复: 20

[已解决]用VBA每行有5个数字相同就过滤 太慢如何改

[复制链接]
发表于 2016-6-20 09:38 | 显示全部楼层 |阅读模式

用VBA每行有5个数字相同就过滤  太慢如何改

最佳答案
2016-6-22 09:23
原先代码为美观,显示在新表中。现按原显示要求作了修改,并对几个代码作了比较。

用VBA每行有5个数字相同就过滤 太慢如何改.rar

36.49 KB, 下载次数: 25

发表于 2016-6-20 13:04 | 显示全部楼层
  1. Option Explicit

  2. Sub demo()
  3.     Dim arr, i%, irow%, j%, max%, temp, brr, jI%, jO%
  4.     Dim dic, str$, nrr, n%
  5.     With Sheet1
  6.         irow = .Cells(.Rows.Count, 1).End(xlUp).Row
  7.         arr = .Range("A11:F" & irow)
  8.     End With
  9.     ReDim brr(1 To UBound(arr, 2))
  10.     ReDim nrr(1 To 10000, 1 To UBound(arr, 2))
  11.     Set dic = CreateObject("scripting.dictionary")
  12.     For i = 1 To UBound(arr)
  13.         For j = 1 To UBound(arr, 2)
  14.             brr(j) = arr(i, j)
  15.         Next
  16.         For jO = 1 To UBound(brr) - 1
  17.             For jI = 1 To UBound(brr) - jO
  18.                 If brr(jI) > brr(jI + 1) Then
  19.                     temp = brr(jI)
  20.                     brr(jI) = brr(jI + 1)
  21.                     brr(jI + 1) = temp
  22.                 End If
  23.             Next
  24.         Next
  25.         str = ""
  26.         For j = 1 To UBound(brr) - 1
  27.             str = str & brr(j)
  28.         Next
  29.         If Not dic.exists(str) Then
  30.             dic(str) = ""
  31.             n = n + 1
  32.             For j = 1 To UBound(arr, 2)
  33.                 nrr(n, j) = arr(i, j)
  34.             Next
  35.         End If
  36.     Next
  37.     Sheet1.Range("W11").Resize(n, UBound(nrr, 2)) = nrr
  38. End Sub
复制代码
没测试,你自己测试下

评分

参与人数 1 +9 收起 理由
vbyou127 + 9 来学习

查看全部评分

回复

使用道具 举报

发表于 2016-6-20 13:38 | 显示全部楼层
这样也不是非常快


用VBA每行有5个数字相同就过滤 太慢如何改.rar

38.42 KB, 下载次数: 12

评分

参与人数 2 +12 收起 理由
vbyou127 + 9 来学习
老司机带带我 + 3 这个方法好,直接在arr这个数组上进行操作,.

查看全部评分

回复

使用道具 举报

发表于 2016-6-20 13:41 | 显示全部楼层
花了我2个小时,看下速度是否满意!
  1. Sub xx1()
  2.     Dim arr, n&, i&, d, brr, crr(), x&, j1&, j2&, j3&, j4&, j5&, y&, str$
  3.     Set d = CreateObject("Scripting.Dictionary")
  4.     With Sheet1
  5.         n = .Cells(.Rows.Count, 1).End(xlUp).Row
  6.         arr = .Range("A11:F" & n)
  7.         ReDim Preserve crr(1 To 6, 1 To 1)
  8.         For i = 1 To 6
  9.             crr(i, 1) = arr(1, i)
  10.         Next
  11.         x = 1
  12.         For i = 2 To n - 10
  13.             For k = 1 To x
  14.                 y = 0
  15.                 str = "|" & crr(1, k) & "|" & crr(2, k) & "|" & crr(3, k) & "|" & crr(4, k) & "|" & crr(5, k) & "|" & crr(6, k) & "|"
  16.                 For j = 1 To 6
  17.                     If InStr(str, "|" & arr(i, j) & "|") Then y = y + 1
  18.                 Next
  19.                 If y >= 5 Then Exit For
  20.             Next
  21.             If y < 5 Then
  22.                 x = x + 1
  23.                 ReDim Preserve crr(1 To 6, 1 To x)
  24.                 For j = 1 To 6
  25.                     crr(j, x) = arr(i, j)
  26.                 Next
  27.             End If
  28.         Next
  29.         .Range("P11").Resize(x, 6) = Application.WorksheetFunction.Transpose(crr)
  30.     End With
  31. End Sub
复制代码

评分

参与人数 1 +9 收起 理由
vbyou127 + 9

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-6-20 14:41 | 显示全部楼层
本帖最后由 vbyou127 于 2016-6-20 16:53 编辑
ghostjiao 发表于 2016-6-20 13:04
没测试,你自己测试下
Sheet1.Range("W11").Resize(n, UBound(nrr, 2)) = nrr  那个是P11  不是W11

速度好快,不过结果有5个相同数字,那些行没有过滤

每行中有5个相同数字就过滤,只保留一行

1        2        3        4        5        6
1        2        3        4        6        7

第一行和第二行1   2   3   4   6 有5个相同数字,只需保留一行就可以

正确结果只有300多行,你那个超过1000行

回复

使用道具 举报

 楼主| 发表于 2016-6-20 14:42 | 显示全部楼层
本帖最后由 vbyou127 于 2016-6-20 16:53 编辑
老司机带带我 发表于 2016-6-20 13:41
花了我2个小时,看下速度是否满意!

还可以再快,字典方法要继续努力
回复

使用道具 举报

 楼主| 发表于 2016-6-20 16:56 | 显示全部楼层
fjmxwrs 发表于 2016-6-20 13:38
这样也不是非常快







还可以快一点


Function ss(ByRef arr() As Integer, ByRef brr() As Integer) As Integer
    Dim i%, j%, k%
    For i = 1 To 6
        For j = 1 To 6
            If arr(i) = brr(j) Then k = k + 1: Exit For
        Next
    Next
    ss = k
End Function

Sub xx()
Start = Timer
    Dim i%, j%, k%, a%(), b%(), ar%(1 To 6), br%(1 To 6), c%, n%, x&
    [p11:v65535].ClearContents

    x = [a65536].End(3).Row

    n = 5
    ReDim a(11 To x, 1 To 6), b(11 To x)
    For i = 11 To x
        For j = 1 To 6
            a(i, j) = Cells(i, j)
        Next
    Next
    c = 11
    b(11) = 11
    For i = 12 To x
        For j = 1 To 6
            ar(j) = a(i, j)
        Next
        For k = 11 To c
            For j = 1 To 6
                br(j) = a(b(k), j)
            Next
            If ss(ar, br) >= n Then GoTo sss
        Next
        c = c + 1
        b(c) = i
sss:
    Next
    For i = 11 To c
        For j = 1 To 6
            Cells(i, [o1].Column + j) = a(b(i), j)
        Next
    Next
    MsgBox Timer - Start
End Sub













回复

使用道具 举报

发表于 2016-6-21 09:09 | 显示全部楼层
vbyou127 发表于 2016-6-20 14:41
Sheet1.Range("W11").Resize(n, UBound(nrr, 2)) = nrr  那个是P11  不是W11

速度好快,不过结果有5个相 ...

理解错了,我再想想{:1312:}
回复

使用道具 举报

发表于 2016-6-21 14:05 | 显示全部楼层
耗时1.1秒,可行?
  1. Dim drr%(1 To 100)
  2. Sub grf()
  3.     Dim d, i&, ii&, n&, j%, xrr%(1 To 6), yrr%(1 To 6)
  4.     t = Timer
  5.     arr = Sheets(1).[a1].CurrentRegion
  6.     Set d = CreateObject("scripting.dictionary")
  7.     For i = 1 To UBound(arr) - 1      '遍历待比较行
  8.         If Not d.exists(i) Then        '只在未过滤的行中寻找
  9.             For j = 1 To 6: xrr(j) = arr(i, j): Next      '赋值待比较行为数组xrr
  10.             For ii = i + 1 To UBound(arr)      '遍历比较行
  11.                 If Not d.exists(ii) Then          '只在未过滤的行中寻找
  12.                     For j = 1 To 6: yrr(j) = arr(ii, j): Next         '赋值比较行为数组yrr
  13.                     If IsOK(xrr, yrr) Then d(ii) = ""        '判断两行数是否有5个以上相同,如有,则标记比较行
  14.                 End If
  15.             Next
  16.         End If
  17.     Next
  18.    
  19.     ReDim crr(1 To UBound(arr) - d.Count, 1 To 6)     '输出未作过标记的行
  20.     For i = 1 To UBound(arr)
  21.         If Not d.exists(i) Then
  22.             n = n + 1
  23.             For j = 1 To 6: crr(n, j) = arr(i, j): Next
  24.         End If
  25.     Next
  26.    
  27.     Sheets(2).[a1].Resize(n, 6) = crr
  28.     MsgBox Timer - t
  29. End Sub

  30. Function IsOK(ByRef arr() As Integer, ByRef brr() As Integer) As Boolean    '判断两行数是否有5个以上相同
  31.     Dim i%, j%, k%
  32.     Erase drr
  33.     For i = 1 To 6
  34.         drr(arr(i)) = 1
  35.     Next
  36.     For i = 1 To 6
  37.         k = k + drr(brr(i))
  38.     Next
  39.     If k >= 5 Then IsOK = True
  40. End Function
复制代码

评分

参与人数 1 +9 收起 理由
vbyou127 + 9 来学习

查看全部评分

回复

使用道具 举报

发表于 2016-6-21 14:09 | 显示全部楼层
结果和7楼有不同,7楼334组,我的是315组。

点评

http://www.excelpx.com/thread-419083-2-1.html  发表于 2016-6-21 14:46
http://www.excelpx.com/thread-419083-2-1.html  发表于 2016-6-21 14:46
http://www.excelpx.com/thread-419083-2-1.html  发表于 2016-6-21 14:45
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 03:07 , Processed in 0.791501 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表