[已解决]求大神写一个 搜索框的功能，详情见附件

lindadada

求大神写一个  搜索框的功能，详情见附件

最佳答案

月排行榜 / 总排行榜

chart888

2017-6-5 19:12

1. Private Sub CommandButton1_Click()
   
2. Dim i, Rng As Range
   
3. Dim m, n, a As Integer
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. On Error Resume Next
   
7. With ActiveSheet
   
8.     m = [A65536].End(xlUp).Row
   
9.     n = [IV9].End(xlToLeft).Column
   
10.     .Cells(5, 1).Resize(1, n).Clear
    
11.     sInt = Application.InputBox(Prompt:="输入账号名")
    
12.     If Len(Trim(sInt)) > 0 Then
    
13.         AA = sInt
    
14.     Else
    
15.         MsgBox Prompt:="没有输入有效的账号"
    
16.         Exit Sub
    
17.     End If
    
18. Set Rng = .Cells(9, 1).Resize(m - 8, n).Find(AA, LookIn:=xlValues, lookat:=1)
    
19.     If Not Rng Is Nothing Then
    
20.         a = Rng.Row
    
21.     Else
    
22.         MsgBox Prompt:="您找到你要的信息"
    
23.         Exit Sub
    
24.     End If
    
25. .Cells(a, 1).Resize(1, n).Copy
    
26. .Cells(5, 1).Resize(1, n).PasteSpecial Paste:=xlPasteValues
    
27. .Cells(3, 1).Resize(1, n).EntireColumn.AutoFit
    
28.     With .Range("A3").CurrentRegion.Borders
    
29.         .LineStyle = xlContinuous
    
30.         .Weight = xlThin
    
31.     End With
    
32.     With .Range("A7").CurrentRegion.Borders
    
33.         .LineStyle = xlContinuous
    
34.         .Weight = xlThin
    
35.     End With
    
36.     With .Range("A3").Resize(3, n)
    
37.             .VerticalAlignment = xlCenter
    
38.             .HorizontalAlignment = xlCenter
    
39.             .Font.Name = "微软雅黑"
    
40.             .Font.Size = 11
    
41.         End With
    
42.         With .Range("A7").Resize(m, n)
    
43.             .VerticalAlignment = xlCenter
    
44.             .HorizontalAlignment = xlCenter
    
45.             .Font.Name = "微软雅黑"
    
46.             .Font.Size = 11
    
47.         End With
    
48. End With
    
49. Application.ScreenUpdating = True
    
50. Application.DisplayAlerts = True
    
51. End Sub

复制代码

跳转到最佳答案楼层

lindadada

附件

chart888

附件

chart888

lindadada 发表于 2017-6-5 16:04
附件

头像都跟我一样谁盗版谁的啊
呵呵

lindadada

chart888 发表于 2017-6-5 16:14
头像都跟我一样谁盗版谁的啊
呵呵

大神，我盗版你的，我马上改，能不能帮忙写一个呢？

lindadada

chart888 发表于 2017-6-5 16:14
附件

附件已上传

chart888

不知道你是不是这个意思随便弄了
如果需要改再说

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Dim s, rg, sInt
   
4. 
   
5. sInt = Application.InputBox(Prompt:="输入姓名")
   
6.     If Len(Trim(sInt)) > 0 Then
   
7.         AA = sInt
   
8.     End If
   
9. Set s = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(3).Row)
   
10.    For Each rg In s
    
11.       If rg.Value = AA Then
    
12.           a = rg.Row
    
13.        End If
    
14. Next
    
15. ActiveSheet.Cells(a, 1).Resize(1, 5).Copy
    
16. ActiveSheet.Cells(2, 7).Resize(1, 5).PasteSpecial Paste:=xlPasteValues
    
17. 
    
18. End Sub

复制代码

lindadada

chart888 发表于 2017-6-5 16:40
不知道你是不是这个意思随便弄了
如果需要改再说

大哥，能不能加下你的QQ，小妹我有点笨！

lindadada

lindadada 发表于 2017-6-5 17:08
大哥，能不能加下你的QQ，小妹我有点笨！

我QQ 2243573864

lindadada

chart888 发表于 2017-6-5 16:14
附件

就是这个