提取与查找

529905149

想要的效果1.将表1中的内容提取到表2中
2.在表3中的C1单元格输入题目关键字，在表2中查找，将整行提取到结果区

lsc900707

第二个要求，写了一个，当然也可以改成工作表事件：

1. Sub 查询()
   
2.     arr = Sheet2.[a1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
4.     For i = 2 To UBound(arr)
   
5.         If InStr(arr(i, 3), [c1]) Then
   
6.             m = m + 1
   
7.             For j = 1 To UBound(arr, 2)
   
8.                 brr(m, j) = arr(i, j)
   
9.             Next
   
10.         End If
    
11.     Next
    
12.     If m Then
    
13.         Range("a4:h" & Rows.Count).ClearContents
    
14.         [a4].Resize(m, UBound(brr, 2)) = brr
    
15.     Else
    
16.         MsgBox "糟糕，你要查询的内容居然找不到耶！"
    
17.     End If
    
18. End Sub
    

复制代码

lsc900707

附件供参考：

529905149

lsc900707 发表于 2018-9-4 17:35
附件供参考：

谢谢您的解答，解决大问题了

529905149

lsc900707 发表于 2018-9-4 17:35
附件供参考：

老师您好，我修改为C1单元格值改变事件，运行后无反应呢？谢谢
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$c$1" Then Exit Sub
     If Len(Range("c1")) = 0 Then Exit Sub
    arr = Sheet2.[a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If InStr(arr(i, 3), [c1]) Then
            m = m + 1
            For j = 1 To UBound(arr, 2)
                brr(m, j) = arr(i, j)
            Next
        End If
    Next
    If m Then
       Range("a4:h" & Rows.Count).ClearContents
       [a4].Resize(m, UBound(brr, 2)) = brr
    Else
        MsgBox "糟糕，你要查询的内容居然找不到耶！"
    End If
End Sub

lsc900707

529905149 发表于 2018-9-5 11:21
老师您好，我修改为C1单元格值改变事件，运行后无反应呢？谢谢
Private Sub Worksheet_Change(ByVal Tar ...

代码要放到设sheet3的代码区哦：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.      If Target.Address <> "$C$1" Then Exit Sub
   
3.       If Len(Target) = 0 Then Exit Sub
   
4.      arr = Sheet2.[a1].CurrentRegion
   
5.      ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.      For i = 2 To UBound(arr)
   
7.          If InStr(arr(i, 3), Target) Then
   
8.              m = m + 1
   
9.              For j = 1 To UBound(arr, 2)
   
10.                  brr(m, j) = arr(i, j)
    
11.              Next
    
12.          End If
    
13.      Next
    
14.      If m Then
    
15.         Range("a4:h" & Rows.Count).ClearContents
    
16.         [a4].Resize(m, UBound(brr, 2)) = brr
    
17.      Else
    
18.          MsgBox "糟糕，你要查询的内容居然找不到耶！"
    
19.      End If
    
20. End Sub

复制代码