[已解决]vba代码执行不了 球论坛高人帮我看看

saghj

用vba编写了一个查询页面，通过下拉列表框里的编号查询出“数据源”工作表里的数据，并将它显示出来
代码如下
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$k$2" Then Exit Sub
Dim arr, brr(), d As New Dictionary
With Sheets("数据源")
arr = .Range("g2:q" & .Range("g65536").End(3).Row)
For b = 1 To UBound(arr)
d(arr(b, 1)) = ""
Next
Range("z2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
g = UBound(arr, 2)
Range(Range("a5"), Cells(14, g)) = ""
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For x = 1 To UBound(arr)
If arr(x, 1) = Range("k2") Then
k = k + 1
For c = 1 To UBound(arr, 2)
brr(k, c) = arr(x, c)
Next
End If
Next
End With
Range("a5").Resize(k, UBound(arr, 2)) = brr

End Sub
代码似乎没什么问题，但就是找不到数据，求论坛里的高手帮着看看，小弟感激不敬

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-2-3 15:30

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. 
   
3.     If Target.Address <> "$K$2" Then Exit Sub
   
4.     Application.EnableEvents = False
   
5.     Application.ScreenUpdating = False
   
6.     Dim arr, brr(), d As New Dictionary
   
7.     With Sheets("数据源")
   
8.         arr = .Range("a2:q" & .Range("g65536").End(3).Row)
   
9.         For b = 1 To UBound(arr)
   
10.             d(arr(b, 1)) = ""
    
11.         Next
    
12.         Range("z2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
    
13.         g = UBound(arr, 2)
    
14.         Range(Range("a5"), Cells(14, "k")) = ""
    
15.         ReDim brr(1 To UBound(arr), 1 To 11)
    
16.         For x = 1 To UBound(arr)
    
17.             If arr(x, 1) = Range("k2") Then
    
18.                 k = k + 1
    
19.                 For c = 1 To UBound(brr, 2)
    
20.                     brr(k, c) = arr(x, c + 6)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.     End With
    
25.     If k > 0 Then
    
26.         Range("a5").Resize(k, UBound(brr, 2)) = brr
    
27.     End If
    
28.     Application.EnableEvents = True
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

跳转到最佳答案楼层

saghj

见附件 ，怎样让数据源里的数据自动显示在查询页面里呢 谢谢

hwc2ycy

第一个错的地方，地址返回的是大写的字母.

1. If Target.Address <> "$K$2" Then Exit Sub

复制代码

saghj

hwc2ycy 发表于 2013-2-3 15:02
第一个错的地方，地址返回的是大写的字母.

谢谢楼上，我改过来后有显示“应用程序定义或对象定义错误”

hwc2ycy

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. 
   
3.     If Target.Address <> "$K$2" Then Exit Sub
   
4.     Application.EnableEvents = False
   
5.     Dim arr, brr(), d As New Dictionary
   
6.     With Sheets("数据源")
   
7.         arr = .Range("a2:q" & .Range("g65536").End(3).Row)
   
8.         For b = 1 To UBound(arr)
   
9.             d(arr(b, 1)) = ""
   
10.         Next
    
11.         Range("z2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
    
12.         g = UBound(arr, 2)
    
13.         Range(Range("a5"), Cells(14, "k")) = ""
    
14.         ReDim brr(1 To UBound(arr), 1 To 11)
    
15.         For x = 1 To UBound(arr)
    
16.             If arr(x, 1) = Range("k2") Then
    
17.                 k = k + 1
    
18.                 For c = 1 To UBound(brr, 2)
    
19.                     brr(k, c) = arr(x, c + 6)
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.     End With
    
24.     If k > 0 Then
    
25.         Range("a5").Resize(k, UBound(arr, 2)) = brr
    
26.     End If
    
27.     Application.EnableEvents = True
    
28. End Sub

复制代码

hwc2ycy

小心当你查到的符合条件的数据超过10行，情况就又不一样了。

hwc2ycy

K是空值嘛，代码重新改了下，你再试试。

hwc2ycy

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. 
   
3.     If Target.Address <> "$K$2" Then Exit Sub
   
4.     Application.EnableEvents = False
   
5.     Dim arr, brr(), d As New Dictionary
   
6.     With Sheets("数据源")
   
7.         arr = .Range("a2:q" & .Range("g65536").End(3).Row)
   
8.         For b = 1 To UBound(arr)
   
9.             d(arr(b, 1)) = ""
   
10.         Next
    
11.         Range("z2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
    
12.         g = UBound(arr, 2)
    
13.         Range(Range("a5"), Cells(14, "k")) = ""
    
14.         ReDim brr(1 To UBound(arr), 1 To 11)
    
15.         For x = 1 To UBound(arr)
    
16.             If arr(x, 1) = Range("k2") Then
    
17.                 k = k + 1
    
18.                 For c = 1 To UBound(brr, 2)
    
19.                     brr(k, c) = arr(x, c + 6)
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.     End With
    
24.     If k > 0 Then
    
25.         Range("a5").Resize(k, UBound(brr, 2)) = brr
    
26.     End If
    
27.     Application.EnableEvents = True
    
28. End Sub

复制代码

最后输出有问题。

saghj

hwc2ycy 发表于 2013-2-3 15:16

brr(k, c) = arr(x, c + 6)
这里为什么要改成c+6？

hwc2ycy

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. 
   
3.     If Target.Address <> "$K$2" Then Exit Sub
   
4.     Application.EnableEvents = False
   
5.     Application.ScreenUpdating = False
   
6.     Dim arr, brr(), d As New Dictionary
   
7.     With Sheets("数据源")
   
8.         arr = .Range("a2:q" & .Range("g65536").End(3).Row)
   
9.         For b = 1 To UBound(arr)
   
10.             d(arr(b, 1)) = ""
    
11.         Next
    
12.         Range("z2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
    
13.         g = UBound(arr, 2)
    
14.         Range(Range("a5"), Cells(14, "k")) = ""
    
15.         ReDim brr(1 To UBound(arr), 1 To 11)
    
16.         For x = 1 To UBound(arr)
    
17.             If arr(x, 1) = Range("k2") Then
    
18.                 k = k + 1
    
19.                 For c = 1 To UBound(brr, 2)
    
20.                     brr(k, c) = arr(x, c + 6)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.     End With
    
25.     If k > 0 Then
    
26.         Range("a5").Resize(k, UBound(brr, 2)) = brr
    
27.     End If
    
28.     Application.EnableEvents = True
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码