Напишите программу, которой вы задаёте набор слов (например, фамилий) через пробел и она выводит их по одному слову в строке и пронумеровав с единицы Payton

Вот ещё варианты решения задач (покороче, без вложенных циклов):
1.
function kw(s:string; c:char):integer;
var sl:string; n,k,i:integer;
begin
n:=0; k:=0;
s:=s+'.';
for i:=1 to length(s) do
 if s[i] in [' ',',',';','.']
    then begin if k>0 then inc(n); k:=0; end
   else if s[i]=c then inc(k);
kw:=n;
end;
var st:string; c:char;
begin
st:='program,  begin,  procedure, var, div, array.';
c:='r';
writeln('m=',kw(st,c));
end.

2. Здесь анализируются только строчные английские буквы. При желании можно добавить заглавные англ. и русские. Всё будет аналогично.
procedure pk(s:string;k:integer);
var a:array['a'..'z'] of integer; i:integer; c:char;
begin
for c:='a' to 'z' do a[c]:=0;
for i:=1 to length(s) do
  if s[i] in ['a'..'z'] then inc(a[s[i]]);
for c:='a' to 'z' do if a[c]<k then writeln(c,' - ',a[c])
end;
var st:string; k:integer;
begin
st:='program,  begin,  procedure, var, div, array.';
k:=2;
pk(st,k);
end.

1)function Counter(s:string;c:char):integer;
var sub:string;
i,k:integer;
begin;
k:=0;
while pos(' ',s)<>0 do
 begin;
  for i:=1 to pos(' ',s)-1 do
    sub:=sub+s[i];
      if pos(c,sub)<>0 then inc(k);
      delete(s,1,pos(' ',s));
      delete(sub,1,length(sub));
end;
if pos(c,s)<>0 then inc(k);
Counter:=k;
end;

2)procedure StrangeSeq(s:string;k:integer);
var i,cou:integer;
sub:string;
ar:array of integer;
arc:array of char;
begin;
setlength(ar,length(s)+1);
setlength(arc,length(s)+1);
cou:=length(s);
while cou<>0 do
begin;
 inc(i);
 arc[i]:=s[1];
 sub:=s[1];
  while pos(sub,s)<>0 do
   begin;
   inc(ar[i]);
   delete(s,pos(sub,s),1);
   end;
  cou:=length(s);
  if (ar[i]>k) and (arc[i]<>' ') then
  writeln('Sign:',arc[i],' count:',ar[i]);
end;
end;