[已解决]提取所需要的条件数据

hhaa999 · 发表于 2014-1-19 20:27

提取所需要的条件数据

最佳答案

大灰狼1976

2014-1-20 16:10

本帖最后由大灰狼1976 于 2014-1-20 16:19 编辑

附件请测试。
顺便说明一下，你的说明里有两处错误：
1、比值=7，提取2011数据，而不是2010数据（附件已改过）
2、2011-2002 *=15，这里应该*=16

Private Sub CommandButton1_Click()
Dim arr, i&, j&, n&, m&, m1&, d As Object, c
Set d = CreateObject("scripting.dictionary")
For i = 2 To [a65536].End(3).Row
n = Left(Cells(i, 1), 4)
If Not d.exists(n) Then d(n) = Range(Columns(1).Find(n, lookat:=xlPart, SearchDirection:=xlPrevious), Columns(1).Find(n, lookat:=xlPart)).Resize(, 3)
Next i
For j = 4 To 2 Step -1
m = 0: m1 = 0
n = Application.Large(d.keys, j)
For Each c In d.keys
If c <= n Then
For i = 1 To UBound(d(c))
If d(c)(i, 2) = "*" Then m = m + 1 Else m1 = m1 + 1
Next i
End If
Next c
n = Application.Large(d.keys, j - 1)
If m / m1 >= 6 Then [f65536].End(3).Offset(1).Resize(UBound(d(n)), 3) = d(n)
Next j
End Sub

复制代码

大灰狼1976 · 发表于 2014-1-20 16:10

本帖最后由大灰狼1976 于 2014-1-20 16:19 编辑

附件请测试。
顺便说明一下，你的说明里有两处错误：
1、比值=7，提取2011数据，而不是2010数据（附件已改过）
2、2011-2002 *=15，这里应该*=16

Private Sub CommandButton1_Click()
Dim arr, i&, j&, n&, m&, m1&, d As Object, c
Set d = CreateObject("scripting.dictionary")
For i = 2 To [a65536].End(3).Row
n = Left(Cells(i, 1), 4)
If Not d.exists(n) Then d(n) = Range(Columns(1).Find(n, lookat:=xlPart, SearchDirection:=xlPrevious), Columns(1).Find(n, lookat:=xlPart)).Resize(, 3)
Next i
For j = 4 To 2 Step -1
m = 0: m1 = 0
n = Application.Large(d.keys, j)
For Each c In d.keys
If c <= n Then
For i = 1 To UBound(d(c))
If d(c)(i, 2) = "*" Then m = m + 1 Else m1 = m1 + 1
Next i
End If
Next c
n = Application.Large(d.keys, j - 1)
If m / m1 >= 6 Then [f65536].End(3).Offset(1).Resize(UBound(d(n)), 3) = d(n)
Next j
End Sub

复制代码

		自动登录	找回密码
密码			注册