设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 用VBA查询
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 4263|回复: 7

[已解决]用VBA查询

[复制链接]
发表于 2016-4-22 08:01 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 August295 于 2016-4-22 08:49 编辑

求助：使用VBA查询数据。（数据量大，数据源里的数据有上万条数据）
说明1、A:D列是数据源，C列是G列查询匹配对象。
2、G列是查询条件，与C列匹配如果相同取该行A:D数据到查询结果区域L:O；如果不同则返回不在查询范围内I列。
3、I列是返回G列查询条件与C列姓名匹配，G列不在C列范围内的数据。
4、L:O列是在数据源查询到返回的结果。
5、查询完毕后返回查询结束。
6、重复点击查询按钮不出错。
7、屏蔽查询空值出错。
详见附件
最佳答案
月排行榜 / 总排行榜
grf1973
2016-4-22 17:00
改写一下。
  1. Sub myquery()
  2.     Dim arr, brr, i&, j&, k&, n%, p%
  3.     arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
  4.     brr = Range("G2:G" & Cells(Rows.Count, 7).End(3).Row)
  5.     ReDim crr2(1 To UBound(arr), 1 To 4)
  6.     ReDim crr1(1 To UBound(brr), 1 To 1)
  7.     Set d = CreateObject("scripting.dictionary")
  8.     For i = 1 To UBound(arr, 1)
  9.         If Len(arr(i, 3)) > 0 Then d(arr(i, 3)) = d(arr(i, 3)) & "," & i
  10.     Next
  11.     For i = 1 To UBound(brr, 1)
  12.         x = brr(i, 1)
  13.         If d.exists(x) Then
  14.             xrr = Split(d(x), ",")
  15.             For j = 1 To UBound(xrr)
  16.                 n = n + 1
  17.                 For k = 1 To 4
  18.                     crr2(n, k) = arr(xrr(j), k)
  19.                 Next
  20.             Next
  21.         Else
  22.             m = m + 1
  23.             crr1(m, 1) = x
  24.         End If
  25.     Next
  26.     Intersect(Range("I:I,L:O"), UsedRange).ClearContents
  27.     [I1] = "不在查询范围内": [L1:O1] = [{"序号","班级","姓名","数量"}]
  28.     [I2].Resize(m) = crr1
  29.     [L2].Resize(n, 4) = crr2
  30.     MsgBox "查询完毕！"
  31. End Sub
复制代码
VBA查询

数据查询.rar

11.16 KB, 下载次数: 38
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2016-4-22 09:16 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub dance()
  2.     Dim arr, x%, i%, n%
  3.     arr = [a1].CurrentRegion
  4.     Range("l2:o1000").ClearContents
  5.     For x = 2 To Cells(Rows.Count, "g").End(3).Row
  6.         For i = 2 To UBound(arr)
  7.             If arr(i, 3) = Range("g" & x) Then
  8.                irow = Cells(Rows.Count, "l").End(3).Row + 1
  9.                Cells(irow, "L") = arr(i, 1)
  10.                Cells(irow, "M") = arr(i, 2)
  11.                Cells(irow, "N") = arr(i, 3)
  12.                Cells(irow, "O") = arr(i, 4)
  13.             Else: Range("i2") = Range("g" & x)
  14.             End If
  15.         Next
  16.     Next
  17. End Sub
复制代码
回复

使用道具 举报

发表于 2016-4-22 09:17 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
测试

数据查询.rar

10.19 KB, 下载次数: 58
回复

使用道具 举报

 楼主| 发表于 2016-4-22 09:47 | 显示全部楼层
本帖最后由 August295 于 2016-4-22 09:57 编辑


你好！
Else: Range("i2") = Range("g" & x)
不在范围内的返回结果只能返回一个结果，多个不能显示。
数据量大后返回结果比较慢。
还是非常感谢！！
回复

使用道具 举报

发表于 2016-4-22 16:17 | 显示全部楼层
本帖最后由 thelastdance 于 2016-4-22 16:19 编辑
August295 发表于 2016-4-22 09:47
你好！
Else: Range("i2") = Range("g" & x)
不在范围内的返回结果只能返回一个结果，多个不能显示。

可以 改的
最好多模拟一部分数据
测试下
单元格循坏有点慢，可以改。。。
重新上传附件吧
回复

使用道具 举报

 楼主| 发表于 2016-4-22 16:46 | 显示全部楼层
本帖最后由 August295 于 2016-4-22 16:59 编辑

代码来源EXCELHOME论坛
fxl447098457提供
效率很高，
小遗憾，就是不能查空，查空报错。
看不懂有高手能帮忙给注释一下，大家学习学习
Sub myquery()
Dim arr, brr, crr1(1 To 500, 1 To 1), crr2(), i&, j&, k&, n%, p%
arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
brr = Range("G2:G" & Cells(Rows.Count, 7).End(3).Row)
For j = 1 To UBound(brr, 1)
For i = 1 To UBound(arr, 1)
  If brr(j, 1) = arr(i, 3) Then
  n = n + 1
  k = k + 1
  ReDim Preserve crr2(1 To 4, 1 To k)
  crr2(1, k) = arr(i, 1): crr2(2, k) = arr(i, 2)
  crr2(3, k) = arr(i, 3): crr2(4, k) = arr(i, 4)
  End If
  Next i
  If n = 0 Then p = p + 1: crr1(p, 1) = brr(j, 1)
  n = 0
  Next j
  Intersect(Range("I:I,L:O"), UsedRange).ClearContents
  [I1] = "不在查询范围内": [L1:O1] = [{"序号","班级","姓名","数量"}]
  [I2].Resize(500) = crr1
  [L2].Resize(k, 4) = WorksheetFunction.Transpose(crr2)
  MsgBox "查询完毕！"
End Sub

回复

使用道具 举报

grf1973
发表于 2016-4-22 17:00 | 显示全部楼层    本楼为最佳答案   
改写一下。
  1. Sub myquery()
  2.     Dim arr, brr, i&, j&, k&, n%, p%
  3.     arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
  4.     brr = Range("G2:G" & Cells(Rows.Count, 7).End(3).Row)
  5.     ReDim crr2(1 To UBound(arr), 1 To 4)
  6.     ReDim crr1(1 To UBound(brr), 1 To 1)
  7.     Set d = CreateObject("scripting.dictionary")
  8.     For i = 1 To UBound(arr, 1)
  9.         If Len(arr(i, 3)) > 0 Then d(arr(i, 3)) = d(arr(i, 3)) & "," & i
  10.     Next
  11.     For i = 1 To UBound(brr, 1)
  12.         x = brr(i, 1)
  13.         If d.exists(x) Then
  14.             xrr = Split(d(x), ",")
  15.             For j = 1 To UBound(xrr)
  16.                 n = n + 1
  17.                 For k = 1 To 4
  18.                     crr2(n, k) = arr(xrr(j), k)
  19.                 Next
  20.             Next
  21.         Else
  22.             m = m + 1
  23.             crr1(m, 1) = x
  24.         End If
  25.     Next
  26.     Intersect(Range("I:I,L:O"), UsedRange).ClearContents
  27.     [I1] = "不在查询范围内": [L1:O1] = [{"序号","班级","姓名","数量"}]
  28.     [I2].Resize(m) = crr1
  29.     [L2].Resize(n, 4) = crr2
  30.     MsgBox "查询完毕！"
  31. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
August295 + 1 赞一个

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-4-22 17:36 | 显示全部楼层
执行代码报错怎么处理。错误提示：”400“
22.png
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-20 00:59 , Processed in 0.211553 second(s), 18 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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