Вывести слова из текста, которые имеют 3 и более согласных букв

procedure TForm1.N1Click(Sender: TObject);
var
  i, count: byte;
  S, T: string;
  
begin
  s:=memo1.text;
  i := 1; 
  while i < Length(S) do begin
    count := 0; 
    T := '';
    while (i <= Length(S))and(UpCase(s[i]) in ['А'..'Я']) do begin
      T := T + s[i]; 
      if UpCase(s[i]) in ['Б',  'В', 'Г', 'Д', 'Ж', 'З', 
      'К', 'Л', 'М', 'Н', 'П', 'Р', 'С', 'Т', 'Ф', 'Х', 
      'Ц', 'Ч', 'Ш', 'Щ', 'б',  'в', 'г', 'д', 'ж', 'з', 
      'к', 'л', 'м', 'н', 'п', 'р', 'с', 'т', 'ф', 'х', 
      'ц', 'ч', 'щ', 'ш'] then inc(count);
      inc(i)
    end;
    if count > 2 then memo2.text:=T; 
    inc(i) 
  end
end.

procedure TForm1.Button1Click(Sender: TObject);
var
  i, count: byte;
  S, T: string;
 
begin
  Memo2.Clear;
  s := memo1.text;
  i := 1;
  while i < Length(S) do begin
    count := 0;
    T := '';
    while (i <= Length(S)) and (AnsiUpperCase(s[i])[1] in ['А'..'Я']) do begin
      T := T + s[i];
      if UpCase(s[i]) in ['Б', 'В', 'Г', 'Д', 'Ж', 'З',
        'К', 'Л', 'М', 'Н', 'П', 'Р', 'С', 'Т', 'Ф', 'Х',
        'Ц', 'Ч', 'Ш', 'Щ', 'б', 'в', 'г', 'д', 'ж', 'з',
        'к', 'л', 'м', 'н', 'п', 'р', 'с', 'т', 'ф', 'х',
        'ц', 'ч', 'щ', 'ш'] then inc(count);
      inc(i)
    end;
    if count > 2 then memo2.Lines.Append( T );
    inc(i)
  end
end;

      if s[i] in ['Б', 'В', 'Г', 'Д', 'Ж', 'З',
        'К', 'Л', 'М', 'Н', 'П', 'Р', 'С', 'Т', 'Ф', 'Х',
        'Ц', 'Ч', 'Ш', 'Щ', 'б', 'в', 'г', 'д', 'ж', 'з',
        'к', 'л', 'м', 'н', 'п', 'р', 'с', 'т', 'ф', 'х',
        'ц', 'ч', 'щ', 'ш'] then inc(count);

var
  i: Integer;
  S, R, GL: string;
  list,list2: TStringList;
begin
r := '!%( )?.,:;'; //одиночные разделители
gl := 'аеёиоуыэюяьъ';
s := Memo1.Text;
 
//заменить все одиночные разделители на пробелы
for i := 1 to Length(r) do s := StringReplace(s, r[i], ' ',[rfReplaceAll]);
 
//заменить все НЕодиночные разделители на пробелы
s := StringReplace(s, ' - ', ' ',[rfReplaceAll]);
 
//для удобства отправим все слова в TStringList (каждое слово - отдельный элемент)
list:=TStringList.Create;
list.DelimitedText := s;
 
list2:=TStringList.Create;
list2.Text := list.Text;
 
//удалить все НЕсогласные из списка слов
for i := 1 to Length(gl) do list.Text := StringReplace(list.Text, gl[i], '',[rfReplaceAll, rfIgnoreCase]);
 
for i := 0 to list.Count-1 do
    if length(list[i]) > 2 then Memo2.Lines.Add(list2[i]);
 
list.Free;
list2.Free;
end;