uses crt;
var d:text; n,i,kt,j,m,dem:longint; s,k:string; a:array[1..1000,1..1000]of string; b,c:array[1..10000]of longint;
begin
clrscr;
   write('Sach can tim:');readln(k);
   assign(d,'SACH.TXT');reset(d);
      while not(eof(d)) do
         begin
            readln(d,n,s);
            b[n]:=1;
            for i:=2 to length(s) do
            if s[i]=' ' then inc(b[n])
               else
                  begin
                     a[n,b[n]]:=a[n,b[n]]+s[i];
                     if a[n,b[n]]=k then
                        begin
                           kt:=0; inc(dem);
                           for j:=1 to m do if c[j]=n then kt:=1;
                           if kt=0 then
                              begin
                                 inc(m);
                                 c[m]:=n;
                              end;
                        end;
                  end;
         end;
   write('Co ',dem,' cuon sach ',k,' trren cac ke:');
   for i:=1 to m do write(c[i],',');
   close(d);
readln
end.

/////////////////////////////////////////////////////////

Bài này mình cũng có giải bên kia rồi nên không phải là copy của người khác đâu nhé!!!

Một số text cho bạn tham khảo: