Sub pazuza()
Dim arr2()
    arr1 = Sheets(1).Cells(1).CurrentRegion.Value
    q = 1
    ReDim arr2(1 To 3, 1 To q)
        With CreateObject("VBScript.RegExp")
            .Pattern = "Гомель(,|ская)"
                For i = 1 To UBound(arr1)
                    If .test(arr1(i, 2)) Then
                        arr2(1, q) = arr1(i, 1)
                        arr2(2, q) = arr1(i, 2)
                        arr2(3, q) = arr1(i, 3)
                        q = q + 1
                        ReDim Preserve arr2(1 To 3, 1 To q)
                    End If
                Next
        End With
        Sheets(2).Cells(1).Resize(q - 1, 3).Value = Application.Transpose(arr2)
        Sheets(2).Activate
End Sub