[已解决]谢谢1032446692 老师。双击某一单元格提取全部记录

lhj323323

老师：

请帮我看看，我写的语句错在哪儿了，谢谢了。
在上传的附件中有详细的说明，是关于双击某一单元格，从数据源表中提取包含此关键词的全部记录，导入到结果表中

求助 .rar (20.71 KB, 下载次数: 10)

2013-5-24 01:03 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

1032446692

2013-5-24 12:38

lhj323323 发表于 2013-5-24 08:58
老师：
如果数据源F列存在空行，数据就提取不出来，是什么原因

1. 
   
2. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
3. Dim arr1, Arr2, Myr As Long, a, j%, r%, x%, arr
   
4. Application.ScreenUpdating = False
   
5. 'On Error Resume Next
   
6. 
   
7. If Target.Count > 1 Then Exit Sub
   
8. 
   
9. 
   
10. '（一）、双击H列从第2行起的某一单元格的关键词，从sheet2中提取对应信息到sheet3中--------------------------
    
11. If Target.Column = 8 And Target.Row > 1 Then
    
12. Cancel = True
    
13. Range("h2:h50").Interior.ColorIndex = xlNone
    
14. Target.Interior.Color = RGB(193, 210, 240)
    
15. 
    
16. 'MsgBox Target.Value
    
17. With Sheet2
    
18. Myr = .Range("a65536").End(xlUp).Row '
    
19. arr1 = .Range("a2:f" & Myr).Value '
    
20. ReDim Arr2(1 To Myr, 1 To 6)
    
21. For x = 2 To Myr
    
22. If arr1(x - 1, 6) Like "*" & Target.Value & "*" Then
    
23. r = r + 1
    
24. 
    
25. For j = 1 To 6
    
26. Arr2(r, j) = arr1(x - 1, j)
    
27. Next
    
28. End If
    
29. Next
    
30. 
    
31. 
    
32. With Sheet3 '结果表[股东分析]
    
33. .Range("a1:f65536").Clear
    
34. .[a1].Resize(1, 6) = Array("标题1", "标题2", "标题3", "标题4", "标题5", "关键词")
    
35. .[a2].Resize(UBound(Arr2, 1), UBound(Arr2, 2)) = Arr2 '从第2行起导入所需数据
    
36. .Rows.Font.Name = "宋体"
    
37. .Rows.Font.Size = 10
    
38. End With
    
39. End With
    
40. End If
    
41. Application.ScreenUpdating = True
    
42. Sheet3.Select
    
43. End Sub
    

复制代码

跳转到最佳答案楼层

1032446692

基本上都是  下标越界的问题   自己多调试调试就可以发现规律了

hwc2ycy

用SQL查询应该比较好。

hwc2ycy

1. Const adUseClient = 3
   
2. Const adModeShareDenyWrite = 8
   
3. Const adModeReadWrite = 3
   
4. Const adModeRead = 1
   
5. 
   
6. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
7.     If Target.Count > 1 Then Exit Sub
   
8.     If Target.Column = 8 And Target.Row > 1 Then
   
9.         Cancel = True
   
10.         Range("h2:h50").Interior.ColorIndex = xlNone
    
11.         Target.Interior.Color = RGB(193, 210, 240)
    
12.         Call ADOQuery(Target.Value)
    
13.         Sheet3.Activate
    
14.     End If
    
15. End Sub
    
16. 
    
17. 
    
18. 
    
19. Sub ADOQuery(strMatch As String)
    
20.     Dim AdoConn As Object, AdoRst As Object
    
21.     Dim strConn$, strSQL$, strFullname$
    
22.     Dim blnHasHeader As Boolean
    
23.     Dim lLastRow As Long
    
24. 
    
25.     On Error GoTo ErrorHandler
    
26. 
    
27.     blnHasHeader = True
    
28.     strFullname = ThisWorkbook.FullName
    
29. 
    
30.     Set AdoConn = CreateObject("ADODB.Connection")
    
31. 
    
32. 
    
33.     strSQL = "select  标题1,标题2,标题3,标题4,标题5 from [sheet2$A1:f" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row & "] where 关键词 like '%" & strMatch & "%'"
    
34. 
    
35. 
    
36.     Select Case Application.Version
    
37.         Case Is = "14.0", "15.0", "12.0"
    
38.             strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
    
39.                       strFullname & "';Extended Properties='Excel 12.0;HDR=" & blnHasHeader & ";imex=1';"
    
40.         Case Else
    
41.             strConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
42.                       "Data Source='" & strFullname & "';Extended Properties='Excel 8.0;HDR=" & blnHasHeader & ";imex=1';"
    
43.     End Select
    
44. 
    
45.     'Debug.Print strConn
    
46. 
    
47.     On Error GoTo ErrorHandler
    
48. 
    
49.     With AdoConn
    
50.         .CommandTimeout = 5
    
51.         .ConnectionTimeout = 5
    
52.         .CursorLocation = adUseClient
    
53.         .Mode = adModeRead
    
54.         .ConnectionString = strConn
    
55.         .Open
    
56.     End With
    
57. 
    
58.     Debug.Print strSQL
    
59. 
    
60.     Application.ScreenUpdating = False
    
61.     Application.DisplayAlerts = False
    
62.     Application.EnableEvents = False
    
63.     Set AdoRst = AdoConn.Execute(strSQL)
    
64. 
    
65.     With Sheet3
    
66.         lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    
67.         If lLastRow > 1 Then
    
68.             .Range("a2:e" & lLastRow).ClearContents
    
69.         End If
    
70.         If AdoRst.RecordCount > 0 Then
    
71.             .Range("a2").CopyFromRecordset AdoRst
    
72.             .Range("a1").CurrentRegion.EntireColumn.AutoFit
    
73.             MsgBox "一共查询到了 " & AdoRst.RecordCount & " 条记录"
    
74.         End If
    
75.     End With
    
76. 
    
77.     Application.ScreenUpdating = True
    
78.     Application.DisplayAlerts = True
    
79.     Application.EnableEvents = True
    
80. 
    
81.     AdoConn.Close
    
82.     Set AdoRst = Nothing
    
83.     Set AdoConn = Nothing
    
84.     Exit Sub
    
85. 
    
86. ErrorHandler:
    
87.     MsgBox Err.Number & vbCrLf & _
    
88.            Err.Description
    
89.     Set AdoRst = Nothing
    
90.     Set AdoConn = Nothing
    
91.     Application.ScreenUpdating = True
    
92.     Application.DisplayAlerts = True
    
93.     Application.EnableEvents = True
    
94. End Sub
    

复制代码

hwc2ycy

另外，高级筛选在这种条件下也是可以的。

lhj323323

1032446692 发表于 2013-5-24 01:26
基本上都是  下标越界的问题   自己多调试调试就可以发现规律了

老师：
如果数据源F列存在空行，数据就提取不出来，是什么原因

只能提取SHEET1中的H3的关键词，而单元格[H2]和[H4]的却提取不出来
求助第二次 .rar (183.75 KB, 下载次数: 8)

2013-5-24 09:05 上传

点击文件名下载附件

lhj323323

hwc2ycy 发表于 2013-5-24 08:29
另外，高级筛选在这种条件下也是可以的。

老师，这个太复杂了，谢谢了

hwc2ycy

你用的FILTER函数，就要注意，FILTER只能针对一维数组了。

1032446692

lhj323323 发表于 2013-5-24 08:58
老师：
如果数据源F列存在空行，数据就提取不出来，是什么原因

1. 
   
2. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
3. Dim arr1, Arr2, Myr As Long, a, j%, r%, x%, arr
   
4. Application.ScreenUpdating = False
   
5. 'On Error Resume Next
   
6. 
   
7. If Target.Count > 1 Then Exit Sub
   
8. 
   
9. 
   
10. '（一）、双击H列从第2行起的某一单元格的关键词，从sheet2中提取对应信息到sheet3中--------------------------
    
11. If Target.Column = 8 And Target.Row > 1 Then
    
12. Cancel = True
    
13. Range("h2:h50").Interior.ColorIndex = xlNone
    
14. Target.Interior.Color = RGB(193, 210, 240)
    
15. 
    
16. 'MsgBox Target.Value
    
17. With Sheet2
    
18. Myr = .Range("a65536").End(xlUp).Row '
    
19. arr1 = .Range("a2:f" & Myr).Value '
    
20. ReDim Arr2(1 To Myr, 1 To 6)
    
21. For x = 2 To Myr
    
22. If arr1(x - 1, 6) Like "*" & Target.Value & "*" Then
    
23. r = r + 1
    
24. 
    
25. For j = 1 To 6
    
26. Arr2(r, j) = arr1(x - 1, j)
    
27. Next
    
28. End If
    
29. Next
    
30. 
    
31. 
    
32. With Sheet3 '结果表[股东分析]
    
33. .Range("a1:f65536").Clear
    
34. .[a1].Resize(1, 6) = Array("标题1", "标题2", "标题3", "标题4", "标题5", "关键词")
    
35. .[a2].Resize(UBound(Arr2, 1), UBound(Arr2, 2)) = Arr2 '从第2行起导入所需数据
    
36. .Rows.Font.Name = "宋体"
    
37. .Rows.Font.Size = 10
    
38. End With
    
39. End With
    
40. End If
    
41. Application.ScreenUpdating = True
    
42. Sheet3.Select
    
43. End Sub
    

复制代码

1032446692

不是空单元格的原因，而是transpose函数的局限性