归纳与总结，以备自查！

ctp_119

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

先来个动态查询-----9种方法。
如图:

动态查询.rar (36.21 KB, 下载次数: 893)

2013-4-9 10:04 上传

点击文件名下载附件

ctp_119

方法三的动画！

ctp_119

普通筛选法代码：

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
    

复制代码

ctp_119

普通循环法：

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
    

复制代码

ctp_119

注意：但凡用到工作表改变事件都给我用上这两句代码：
Application.EnableEvents = False
Application.EnableEvents = true

ctp_119

数组法：

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
    

复制代码

ctp_119

用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
    

复制代码

ctp_119

字典法：当然里面也有数组了。

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
    

复制代码

ctp_119

最后一种方法：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
    

复制代码

ctp_119

下面是一个新的话题，读取工作簿的三张方法。都来自论坛中网友的提问，现做一总结归纳。
看图：



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

2013-4-9 10:25 上传

点击文件名下载附件