ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 27660|回复: 86

[原创] 归纳与总结,以备自查!

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2013-4-9 10:05 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 ctp_119 于 2015-4-21 14:52 编辑

本帖是自己根据平时论坛回答问题之后,把类似的问题进行归纳总结以备自己查询学习之用,欢迎贴上更多的方法和思路,不需无用跟帖。。。谢谢!!!

先来个动态查询-----9种方法。
如图:
QQ截图20130409100255.jpg
动态查询.rar (36.21 KB, 下载次数: 896)

评分

7

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:06 | 显示全部楼层
本帖最后由 ctp_119 于 2013-4-9 10:07 编辑

ccc.gif

方法三的动画!

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:09 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
普通筛选法代码:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim ir As Integer
  3. If Target.Row <> 1 Or Target.Column <> 3 Then Exit Sub   '行号不等于1或者列号不等于3(即当前活动单元格不是C1)就退出过程。
  4. Application.ScreenUpdating = False   '冻结屏幕刷新,以加快运行速度
  5. Application.EnableEvents = False     '关闭事件联动反应
  6. With Sheets("原始数据")            'with引用原始数据表
  7.     ir = .[a65536].End(xlUp).Row     '测算原始数据的行数
  8.     .Range("$A$1:$E$" & ir).AutoFilter Field:=1, Criteria1:=Range("C1")      '设置以C1单元格的值对原始数据进行筛选.
  9.     .AutoFilter.Range.SpecialCells(12).Copy Sheet5.Range("A3")          '复制可见自动筛选结果到当前工作表的A3单元格.
  10.     '.ShowAllData              '恢复原始数据/原始数据全部显示.
  11.     .Cells.AutoFilter     '去除自动筛选
  12. End With              '结束with引用.
  13. Application.EnableEvents = True     '打开事件反应
  14. Application.ScreenUpdating = True        '刷新屏幕
  15. End Sub
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:10 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
普通循环法:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row <> 1 Or Target.Column <> 3 Then Exit Sub
  3. Application.ScreenUpdating = False
  4. Application.EnableEvents = False
  5. Dim ir As Integer
  6. Dim i As Integer
  7. Dim j As Integer
  8. Range("a4:e" & [a65536].End(xlUp).Row).ClearContents   '动态清除原有数据,目的是防止无用数据残留。
  9. With Sheets("原始数据")
  10. j = 4
  11. ir = .[a65536].End(xlUp).Row
  12. For i = 2 To ir
  13.     If .Cells(i, 1) = Cells(1, 3) Then
  14.         .Cells(i, 1).Resize(1, 5).Copy Cells(j, 1)
  15.         j = j + 1
  16.     End If
  17. Next
  18. End With
  19. Application.EnableEvents = True
  20. Application.ScreenUpdating = True
  21. End Sub
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:13 | 显示全部楼层
注意:但凡用到工作表改变事件都给我用上这两句代码:
Application.EnableEvents = False
Application.EnableEvents = true

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:14 | 显示全部楼层
数组法:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row <> 1 Or Target.Column <> 3 Then Exit Sub
  3. Application.ScreenUpdating = False
  4. Application.EnableEvents = False
  5. Dim ir As Integer
  6. Dim i As Integer
  7. Dim s As Integer
  8. Dim arr As Variant
  9. Dim ar() As Variant
  10. With Sheets("原始数据")
  11. ir = .[a65536].End(xlUp).Row
  12. arr = .Range("a2:e" & ir)
  13. For i = 1 To ir - 1
  14.     If arr(i, 1) = Range("c1") Then
  15.         s = s + 1
  16.         ReDim Preserve ar(1 To 5, 1 To s)
  17.         ar(1, s) = arr(i, 1)
  18.         ar(2, s) = arr(i, 2)
  19.         ar(3, s) = arr(i, 3)
  20.         ar(4, s) = arr(i, 4)
  21.         ar(5, s) = arr(i, 5)
  22.     End If
  23. Next
  24. Range("a4").Resize(s, 5) = Application.WorksheetFunction.Transpose(ar)
  25. End With
  26. Application.EnableEvents = True
  27. Application.ScreenUpdating = True
  28. End Sub
复制代码



TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:16 | 显示全部楼层
用find+findnext法:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row <> 1 Or Target.Column <> 3 Then Exit Sub
  3. Application.ScreenUpdating = False
  4. Application.EnableEvents = False
  5. Dim rng As Range
  6. Dim findrng As String
  7. Dim j As Integer
  8. Range("a4:e" & [a65536].End(xlUp).Row).ClearContents   '动态清除原有数据,目的是防止无用数据残留。
  9. j = 3
  10. With Sheets("原始数据").Range("A:A")
  11.     Set rng = .Find(Range("c1").Value, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole)
  12.     If Not rng Is Nothing Then
  13.         findrng = rng.Address
  14.         Do
  15.             j = j + 1
  16.             rng.Resize(1, 5).Copy Cells(j, 1)
  17.             Set rng = .FindNext(rng)
  18.         Loop While Not rng Is Nothing And rng.Address <> findrng
  19.      End If
  20. End With
  21. Application.EnableEvents = True
  22. Application.ScreenUpdating = True
  23. End Sub
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:17 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
字典法:当然里面也有数组了。
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row <> 1 Or Target.Column <> 3 Then Exit Sub
  3. Application.ScreenUpdating = False
  4. Application.EnableEvents = False
  5. Dim ir As Integer
  6. Dim i As Integer
  7. Dim arr As Variant
  8. Dim ar As Variant
  9. Dim brr()
  10. Dim dic As Object
  11. Set dic = CreateObject("scripting.dictionary")
  12. With Sheets("原始数据")
  13. ir = .[a65536].End(xlUp).Row
  14. arr = .Range("a2:e" & ir)
  15. For i = 1 To ir - 1
  16.     If arr(i, 1) = Range("c1") Then
  17.         If Not dic.exists(arr(i, 1)) Then
  18.             dic(arr(i, 1)) = dic(arr(i, 1)) & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5)
  19.         Else
  20.             dic(arr(i, 1)) = dic(arr(i, 1)) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5)
  21.         End If
  22.     End If
  23. Next
  24. ar = dic.items
  25. s = UBound(Split(ar(0), ",")) + 1
  26. ReDim brr(1 To s / 4, 1 To 4)
  27. For j = 1 To s / 4
  28.     For t = 1 To 4
  29.         brr(j, t) = Split(ar(0), ",")(k)
  30.         k = k + 1
  31.     Next t
  32. Next j
  33. End With
  34. Range("b4").Resize(UBound(brr), 4) = brr
  35. Range("a4") = Range("c1")
  36. Range("a4:a" & UBound(brr) + 3).FillDown
  37. Application.EnableEvents = True
  38. Application.ScreenUpdating = True
  39. End Sub
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:19 | 显示全部楼层
最后一种方法:ADO+SQL法,代码简短。
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row <> 1 Or Target.Column <> 3 Then Exit Sub
  3. Application.ScreenUpdating = False
  4. Application.EnableEvents = False
  5. Range("a4:e" & [a65536].End(xlUp).Row).ClearContents   '动态清除原有数据,目的是防止无用数据残留。
  6. Dim objcn As New ADODB.Connection
  7. objcn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= " & ThisWorkbook.FullName
  8. Sql = "select 考号,姓名,班级代码,学科,分数 from [原始数据$] where 考号=" & Range("c1")
  9. [a4].CopyFromRecordset objcn.Execute(Sql)
  10. objcn.Close
  11. Set objcn = Nothing
  12. Application.EnableEvents = True
  13. Application.ScreenUpdating = True
  14. End Sub
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2013-4-9 10:26 | 显示全部楼层
下面是一个新的话题,读取工作簿的三张方法。都来自论坛中网友的提问,现做一总结归纳。
看图: jj.jpg



读取工作簿3种方法.rar (175.07 KB, 下载次数: 560)

评分

2

查看全部评分

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

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-23 00:17 , Processed in 0.045400 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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