Изменить немного совсем немного.

Program k;
Uses Crt;
 
Type TInf=Record
        Nam: Integer;
        Num: Integer;
        FIO: String;
        Age: Integer;
        Stature,Weight: Integer;
        O1,O2,O3,O4,O5,OAverage: Integer;
        Friend: Integer;
        Gold: Integer;
        Zodiac: String;
        Birth: String;
     end;
     TTree=^Tree;
     Tree=Record
        Inf:TInf;
        Left,Right: TTree;
     end;
 
Procedure Tab(n: Integer); Begin GoToXY(n,WhereY); End;
 
Procedure ShowHeader;
Begin
   Write('№  ФИО            Возраст   Рост Вес   Друзья   Деньги   Зодиак   Родился');
   WriteLn;
End;
Procedure Show(I: TInf);
Begin
   Write(I.Num);
   Tab(5);Write(I.FIO);
   Tab(20);Write(I.Age);
   Tab(30);Write(I.Stature);
   Tab(35);Write(I.Weight);
   Tab(40);Write(I.Friend);
   Tab(50);Write(I.Gold);
   Tab(60);Write(I.Zodiac);
   Tab(70);Write(I.Birth);
   WriteLn;
End;
 
Procedure Input(Var I: TInf);
Begin
   Write(' 1. номер по списку    : ');ReadLn(I.Num);
   Write(' 2. ФИО                : ');ReadLn(I.FIO);
   Write(' 3. номер группы               : ');ReadLn(I.Nam);
   Write(' 4. Возраст            : ');ReadLn(I.Age);
   Write(' 5. Рост               : ');ReadLn(I.Stature);
   Write(' 6. Вес                : ');ReadLn(I.Weight);
   Write(' 7. Средний балл       : ');ReadLn(I.OAverage);
   Write(' 8. Количество друзей      : ');ReadLn(I.Friend);
   Write(' 9. Сумма на банковском счете : ');ReadLn(I.Gold);
   Write(' 10. Знак Зодиака              : ');ReadLn(I.Zodiac);
   Write('11. Дата рождения             : ');ReadLn(I.Birth);
End;
 
Function SignKey(A,B: TInf): Boolean;
Begin SignKey:=False;
   If A.Stature<B.Stature then SignKey:=True;
End;
Function FindKey(A,B: TInf): Boolean;
Begin FindKey:=False;
   If A.Stature=B.Stature then FindKey:=True;
End;
 
Function NewSheet(X:TInf): TTree;
Var T: TTree;
Begin New (T); T^.Inf:=X; T^.Right:=Nil; T^.Left:=Nil; NewSheet:=T; End;
 
Procedure AddSheet(Var R: TTree; N: TInf);
Begin
   If R<>Nil then begin
      If SignKey(R^.Inf,N) then begin
         If R^.Left=Nil then R^.Left:=NewSheet(N) else AddSheet(R^.Left,N);
      end else begin
         If R^.Right=Nil then R^.Right:=NewSheet(N) else AddSheet(R^.Right,N);
      end;
   end else begin
      R:=NewSheet(N);
   end;
End;
 
Procedure AddTree(Var R: TTree; N: TTree);
Begin
   If R<>Nil then begin
      If N<>Nil then begin
         If SignKey(R^.Inf,N^.Inf) then begin
            If R^.Left=Nil then R^.Left:=N else AddTree(R^.Left,N);
         end else begin
            If R^.Right=Nil then R^.Right:=N else AddTree(R^.Right,N);
         end;
      end;
   end else begin
      R:=N;
   end;
End;
 
Function Find(R: TTree; F: TInf): TTree;
Var t: Ttree;
Begin t:=Nil;
   If R<>Nil then begin
      If FindKey(R^.Inf,F) then begin
         t:=R;
      end else begin
         t:=Find(R^.Left,F);
         If t=Nil then t:=Find(R^.Right,F);
      end;
   end;
   Find:=t;
End;
 
Procedure ShowTree(R: TTree);
Begin
   If R<>Nil then begin
      Show(R^.Inf);
      If R^.Left <> nil then ShowTree(R^.Left);
      If R^.Right <> nil then ShowTree(R^.Right);
   end;
End;
 
Function DeleteNode(R: TTree;W: TTree):TTree;
Var t: TTree;
Begin t:=Nil;
   If R<>Nil then begin
      If W<> Nil then begin
         If R^.Left = W then begin
            R^.Left:=W^.Left;
            t:=W^.Right;
            Dispose(W);
         end else begin
            t:=DeleteNode(R^.Left,W);
         end;
         If t=Nil Then
            If R^.Right = W then begin
               R^.Right:=W^.Left;
               t:=W^.Right;
               Dispose(W);
            end else begin
               t:=DeleteNode(R^.Right,W);
            end;
      end;
   end;
   DeleteNode:=t;
End;
 
Procedure DeleteTree(Var R: TTree;W: TTree);
Begin
   If R=W then begin
      R:=W^.Left;
      AddTree(R,W^.Right);
      Dispose(W);
   end else AddTree(R,DeleteNode(R,W));
End;
 
Procedure Done(R: TTree);
begin
   If R<> nil then begin
      If R^.Left <> nil then Done(R^.Left);
      If R^.Right <> nil then Done (R^.Right);
      Dispose(R);
   End;
End;
 
Procedure Print(T: TTree; g: integer);
Const k=6;
Begin
   If T=nil then Writeln ('Дерево пустое') else begin
      g:=g+1;
      If T^.Right <> nil then Print (T^.Right, g);
      Tab(k*g); Writeln (T^.Inf.Stature);
      If T^.Left <> nil then Print (T^.Left,g);
      g:=g-1;
   End;
End;
 
 
 Var Root,W: TTree; I: TInf; n: Integer;
BEGIN ClrScr;
 Randomize;
 Root:=Nil;
 For n:=1 to 5 do begin
   WriteLn('-===[запись: ',n,']=====---');
    Input(I);
    AddSheet(Root,I);
 end;
 WriteLn;
 WriteLn('Введённые данные: ');
 ShowHeader;ShowTree(Root); WriteLn;
 ReadLn;
 
 WriteLn('Отображение в виде дерева:');
 Print(Root,0);
 ReadLn;
 
 WriteLn('Введите данные для вставки: ');
 Input(I);AddSheet(Root,I);
 
 WriteLn('Результат вставки нового элемента: ');
 ShowHeader;ShowTree(Root); WriteLn;
 ReadLn;
 
 WriteLn('Отображение в виде дерева:');
 Print(Root,0);
 ReadLn;
 
 While W=Nil do begin
    Write('Введите значение ключа для поиска и удаления элемента: ');ReadLn(I.Num);
    W:=Find(Root,I);
    If W=Nil Then WriteLn('Элемент не найден. Повторите ввод.');
 end;
 
 WriteLn('Найден элемент:');
 ShowHeader;Show(W^.Inf); WriteLn;
 
 WriteLn('Удаляем найденный элемент!');
 DeleteTree(Root,W);
 
 WriteLn('Дерево после удаления найденного элемента: ');
 ShowHeader;ShowTree(Root);
 ReadLn;
 
 WriteLn('Отображение в виде дерева:');
 Print(Root,0);
 ReadLn;
 
 Done(Root);
END.