[已解决]求快速提取符合c列条件的b列数据到e列的vba程序

rangevba · 发表于 2016-3-30 15:35

1、b5开始的b列各单元格分别填有不同的数据且每2个数字间空1格。
2、c5单元格填有条件数据，以等号为界，等号右边数字每2个数字间空1格,等号左边为区间条件，表示等号右边的数据与b列某个单元格数据个数相同的数据个数。
如c5条件：
1-2=3 8 15 21 23 表示在：3 8 15 21 23 这5个数中有1到2个数据与b列某个单元格有1到2个数据相同（也就是大家都有的数据）。
4、点击按钮后，c5单元格的数字对b5开始的b列各单元格的所有数字进行查找，b5开始的b列各单元格的数字与c5单元格的数字有1-2格相同时，则对应的b列单元格数据就被依次提取到e5开始的e列各单元格.
谢谢！

提取数据.zip (14.47 KB, 下载次数: 20)

橘子红 · 发表于 2016-3-30 15:59

Sub x()
Dim k1, k2, x, y, r, a, b, s, c()
k1 = Val(Split(Split([c5], "=")(0), "-")(0))
k2 = Val(Split(Split([c5], "=")(0), "-")(1))
a = Split(Split([c5], "=")(1), " ")
b = Range("b5:b" & [b65536].End(3).Row)
For x = 1 To UBound(b)
For y = 0 To UBound(a)
If InStr(b(x, 1), a(y)) Then s = s + 1
Next
If s <= k2 And s >= k1 Then
r = r + 1
ReDim Preserve c(1 To 1, 1 To r)
c(1, r) = b(x, 1)
End If
s = 0
Next
[f:f].Clear
[f5].Resize(r) = Application.Transpose(c)
End Sub

复制代码

rangevba · 发表于 2016-3-30 17:10

橘子红发表于 2016-3-30 15:59

版主真厉害，程序经测试满足要求，谢谢！

rangevba · 发表于 2016-3-30 17:23

橘子红发表于 2016-3-30 15:59

版主你好，如果把c列的条件设为21条一组（其他不变）程序将怎样修改，具体如下：

1、b3开始的b列各单元格分别填有不同的数据且每2个数字间空1格。
2、c3开始的c列各单元格分别填有不同的条件数据，以等号为界，等号右边数字每2个数字间空1格,等号左边为区间条件，表示等号右边的数据与b列某个单元格数据个数相同的数据个数。
  如c列条件：
1-2=3 8 15 21 23       表示在：3 8 15 21 23       这5个数中有1到2个与b列某个单元格数据的个数相同数据个数（也就是大家都有的数据）。
0-3=4 12 15 20 33 35 36 表示在：4 12 15 20 33 35 36  这7个数中有0到3个与b列某个单元格数据的个数相同数据个数（也就是大家都有的数据）。

3、c3开始的c列，每行为一个条件每21行为1组，即c3：c23为第1组，c24：c44为第2组，c45：c65为第3组。。。。。。

4、点击按钮后c3开始的c列各组21个条件依次分别对b3开始的b列各单元格的所有数字进行查找，同时符合各组21个条件的b列数组就被依次提取并填写在e3开始的e列各单元格，

5、要求计算顺序是：
依次查找依次填入，首先第1组条件开始查找，第1组条件查找完并提取数字后再接着第2组开始查找，第2组条件查找完并提取数字后再接着第3组开始查找。

如附件中：查找第1组（即c3：c23为第1组）数据的结果有9组数据（依次填入d列黄色数据），程序自动转入第2组；
         查找第2组（c24：c44为第2组）数据的结果有7组数据（接第1组数据后面填入即d列蓝色数据），程序自动转入第3组；
         查找第3组（c45：c65为第3组）数据的结果有3组数据（接第2组数据后面填入d列黄色数据），程序自动转入第4组；
         。。。。。。

谢谢！

提取数据21.zip (23.49 KB, 下载次数: 11)

rangevba · 发表于 2016-4-9 16:10

橘子红发表于 2016-3-30 15:59

版主你好，本程序用在2010上时，当结果大于10万行时，就出现类型不匹配的情况，能改进一下程序，让结果大于10万吗，谢谢！

橘子红 · 发表于 2016-4-9 16:12

b = Range("b5:b" & [b65536].End(3).Row)
第6行改成 Range("b5:b" & cells(rows.count,2).End(3).Row)

试试

rangevba · 发表于 2016-4-9 16:38

橘子红发表于 2016-4-9 16:12
b = Range("b5:b" & .End(3).Row)
第6行改成 Range("b5:b" & cells(rows.count,2).End(3).Row)

版主你好，试了一下，还是不行，提示与前面一样，请版主再出手，谢谢！

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

[已解决]求快速提取符合c列条件的b列数据到e列的vba程序

相关帖子

评分

评分