Option Explicit
'Option Private Module
'====================================================================================================
Sub Finder()
Dim sh As Worksheet, aAll, aRes()
Dim t!, r&, c&, n&, i&, ii&, fCut As Boolean

t = Timer
fCut = True                     ' тут задаём, обрезать или нет
Set sh = Worksheets("TDSheet")  ' тут задаём лист

aAll = sh.UsedRange.Value2                                  ' берём всю рабочую область листа в массив (тут может переполнится память)
ReDim aRes(1 To UBound(aAll, 1) * UBound(aAll, 2), 1 To 1)  ' создаём такой же по количеству "ячеек" пустой массив, но размером с один столбец (тут тоже может переполнится память)

For c = 1 To UBound(aAll, 2)
    For r = 1 To UBound(aAll, 1)
        i = InStr(aAll(r, c), "ГР0000")                     ' ищем позицию вхождения нужной подстроки (с учётом регистра) в очередном значении
        If i Then                                           ' если нашли …
            If fCut Then                                        ' если надо обрезать …
                ii = InStr(i + 1, aAll(r, c), " ")                  ' ищем пробел после найденной позиции
                If ii = 0 Then ii = 33000                           ' если пробела нет, то присваиваем заведомо большое число (ограничение Excel на количество символов в ячейке)
                n = n + 1: aRes(n, 1) = Mid$(aAll(r, c), i, ii - i) ' записываем в новый массив ОБРЕЗАННОЕ старое значение
            Else                                                ' если НЕ надо обрезать …
                n = n + 1: aRes(n, 1) = aAll(r, c)                  ' записываем в новый массив ВСЁ значение из старого
            End If
        End If
    Next r
Next c
If n = 0 Then MsgBox "Nothing …", vbExclamation, Format$(Timer - t, "0.00"): Exit Sub   ' если ничего не нашли, то выходим с сообщением (время работы в заголовке)

Application.ScreenUpdating = False      ' отключаем обновление экрана
    Worksheets.Add after:=sh                ' вставляем лист после того, с которого отбирали значения
    Cells(1, 1).Resize(n, 1).Value2 = aRes  ' выгружаем в столбец всё найденное
Application.ScreenUpdating = True       ' включаем обновление экрана

MsgBox "Find Values: " & Format$(n, "#,##0"), vbInformation, Format$(Timer - t, "0.00") ' выводим сообщение о найденном (время работы в заголовке)
End Sub
'====================================================================================================