[已解决]求简单查询窗体的VBA代码

moku2006

求简单查询客户名称的窗体代码

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-3 14:46

1. Dim arrSource, arrResult
   
2. 
   
3. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
4.     With Me.ListBox1
   
5.         If .ListIndex > -1 Then
   
6.             Sheet1.Range("b6").Value = .List(.ListIndex)
   
7.         Else
   
8.             MsgBox "列表框无选项"
   
9.         End If
   
10.     End With
    
11. End Sub
    
12. 
    
13. Private Sub TextBox1_Change()
    
14. 
    
15.     arrResult = Filter(arrSource, Me.TextBox1.Value, True, vbBinaryCompare)
    
16.     If UBound(arrResult) <> -1 Then
    
17.         Me.ListBox1.List = arrResult
    
18.     Else
    
19.         Me.ListBox1.Clear
    
20.     End If
    
21. End Sub
    
22. 
    
23. Private Sub UserForm_Initialize()
    
24.     With Sheet1
    
25.         arrSource = .Range(.Range("a2"), .Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).Value
    
26.         arrSource = WorksheetFunction.Index(arrSource, 0, 1)
    
27.         arrSource = WorksheetFunction.Transpose(arrSource)
    
28.         Me.ListBox1.List = arrSource
    
29.     End With
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Dim arrSource, arrResult
   
2. 
   
3. 
   
4. Private Sub TextBox1_Change()
   
5.         arrResult = Filter(arrSource, Me.TextBox1.Value, True, vbBinaryCompare)
   
6.         If UBound(arrResult) <> -1 Then
   
7.             Me.ListBox1.List = arrResult
   
8.         Else
   
9.             Me.ListBox1.Clear
   
10.         End If
    
11. End Sub
    
12. 
    
13. 
    
14. Private Sub UserForm_Initialize()
    
15.     With Sheet1
    
16.         arrSource = .Range(.Range("a2"), .Cells(Rows.Count, 1).End(xlUp)).Value
    
17.         arrSource = WorksheetFunction.Transpose(arrSource)
    
18.     End With
    
19. End Sub

复制代码

hwc2ycy

双击后，列表框的内容写入单元格。

1. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
2.     With Me.ListBox1
   
3.         Sheet1.Range("b6").Value = .List(.ListIndex)
   
4.     End With
   
5. End Sub

复制代码

hwc2ycy

双击方法有缺陷，重新改了下。

1. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
2.     With Me.ListBox1
   
3.         If .ListIndex > -1 Then
   
4.             Sheet1.Range("b6").Value = .List(.ListIndex)
   
5.         Else
   
6.             MsgBox "列表框无选项"
   
7.         End If
   
8.     End With
   
9. End Sub

复制代码

hwc2ycy

求助.rar (20.11 KB, 下载次数: 15)

2013-9-3 14:37 上传

点击文件名下载附件

moku2006

hwc2ycy 发表于 2013-9-3 14:37

能不能一开始进入的窗体的时候，就把所有的客户名称导入呀，求大神解答

hwc2ycy

改了下，有个潜在的漏洞。

求助.rar (19.66 KB, 下载次数: 41)

2013-9-3 14:43 上传

点击文件名下载附件

hwc2ycy

moku2006 发表于 2013-9-3 14:41
能不能一开始进入的窗体的时候，就把所有的客户名称导入呀，求大神解答

可以呀。

hwc2ycy

1. Dim arrSource, arrResult
   
2. 
   
3. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
4.     With Me.ListBox1
   
5.         If .ListIndex > -1 Then
   
6.             Sheet1.Range("b6").Value = .List(.ListIndex)
   
7.         Else
   
8.             MsgBox "列表框无选项"
   
9.         End If
   
10.     End With
    
11. End Sub
    
12. 
    
13. Private Sub TextBox1_Change()
    
14. 
    
15.     arrResult = Filter(arrSource, Me.TextBox1.Value, True, vbBinaryCompare)
    
16.     If UBound(arrResult) <> -1 Then
    
17.         Me.ListBox1.List = arrResult
    
18.     Else
    
19.         Me.ListBox1.Clear
    
20.     End If
    
21. End Sub
    
22. 
    
23. Private Sub UserForm_Initialize()
    
24.     With Sheet1
    
25.         arrSource = .Range(.Range("a2"), .Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).Value
    
26.         arrSource = WorksheetFunction.Index(arrSource, 0, 1)
    
27.         arrSource = WorksheetFunction.Transpose(arrSource)
    
28.         Me.ListBox1.List = arrSource
    
29.     End With
    
30. End Sub
    

复制代码

moku2006

hwc2ycy 发表于 2013-9-3 14:46

大神太强了，崇拜