Option Explicit
Sub GetFromAct()
Dim arrFull(), Temp, X
Dim t@, nr&, nc%, r&, c%, i&, n&
Dim whatFind$, delimList$
Application.ScreenUpdating = 0: On Error GoTo er: delimList = ";": t = Timer
arrFull = [??].Value
nr = [??].Rows.Count: nc = [??].Columns.Count
whatFind = ActiveSheet.Range("E10").Value
ReDim arrFind(0 To nr * (nc - 1)): i = -1
For n = 1 To nr
Temp = Replace$(arrFull(n, 4), delimList, Chr(32))
Temp = Application.WorksheetFunction.Trim(Temp)
Temp = "%%%" & Replace$(Temp, Chr(32), "%%%") & "%%%"
If InStr(Temp, "%%%" & whatFind & "%%%") > 0 Then
For c = 2 To nc
i = i + 1
arrFind(i) = arrFull(n, c)
Next c
End If
Next n
If i < 0 Then MsgBox "?????? ?? ???????", vbInformation, "?????? ????????": GoTo fin
ReDim Preserve arrFind(0 To i)
nc = nc - 1: nr = (i + 1) / nc
ReDim arrInput(1 To nr, 1 To nc): n = 0: i = 0
For r = 1 To nr
For c = 1 To nc
arrInput(r, c) = arrFind(i)
i = i + 1
Next c
Next r
ActiveSheet.Range("T8").Resize(nr, nc).Value = arrInput
t = Round((Timer - t) * 1000, 4)
MsgBox "?????? ?????????!" & vbLf & vbLf & "????? ??????: " & t, vbInformation, "??????"
GoTo fin
er: MsgBox "?????????????? ??????!", vbCritical, "?????? ?????????"
ex: MsgBox "??????", vbInformation, "?????"
fin: On Error GoTo 0: Application.ScreenUpdating = 1
End Sub
