excel vba查找问题

[u014372904]

以下代码只能查找关键字所在行，如何修改可以查找所在行以及所在行的下面四行 Sub test() Dim Arr, Brr Dim Srr(1 To 10000, 1 To 12) Dim D As Object Set D = CreateObject("scripting.dictionary") Set wb = GetObject(ThisWorkbook.Path & "\" & "aaa.xlsx") With wb.Sheets("清单") Arr = .Range("A3:L" & .[B3].End(xlDown).Row) End With With Sheets("查找") Brr = .Range("A2:B2")'a2：b2查询单元格为a2:b2 End With For J = 1 To UBound(Brr, 2) If Brr(1, J) <> "" Then N = N + 1 D(N) = J End If Next If N = 0 Then MsgBox "请输入条件" Exit Sub End If For I = 1 To UBound(Arr) K = 0 For J = 1 To N If Arr(I, D(J)) Like "*" & Brr(1, D(J)) & "*" Then K = K + 1 Next If K = N Then S = S + 1 For J = 1 To UBound(Arr, 2) Srr(S, J) = Arr(I, J) Next End If Next With Sheets("查找") .Range("A5:L10000").Clear If S = 0 Then MsgBox "查无" Exit Sub End If .[A5].Resize(S, 12) = Srr MsgBox "查询成功" End With End Sub