Sub GetData()
Dim arr, brr(), buf(), rlt()
Dim i As Long, j As Long, k As Long, m As Long, n As Long, x As Long, y As Long
arr = Sheets("Sheet2").Range("a2:e13")
ReDim brr(LBound(arr, 2) To UBound(arr, 2), LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
If arr(i, 2) = Sheets("Sheet1").Range("b2") Then
For j = LBound(arr, 2) To UBound(arr, 2)
brr(j, LBound(arr) + k) = arr(i, j)
Next j
k = k + 1
End If
Next i
ReDim buf(LBound(brr, 2) To UBound(brr, 2), LBound(brr) To UBound(brr))
For i = LBound(brr) To UBound(brr)
For j = LBound(brr, 2) To UBound(brr, 2)
buf(j, i) = brr(i, j)
Next j
Next i
m = LBound(buf)
n = LBound(buf) + 6 - 1 '最前6行
x = LBound(buf, 2) + 3 - 1
y = UBound(buf, 2)
ReDim rlt(m To n, x To y)
For i = m To n
For j = x To y
rlt(i, j) = buf(i, j)
Next
Next
Sheets("Sheet1").Range("b5:d10").ClearContents
Sheets("Sheet1").Range("b5:d10") = rlt
End Sub
运行实测图: