Здравствуйте, Артемий Тотктонада!

Проограмма в приложении.
Удачи!

Приложение:
var a:array[0..9]of byte; b,c:integer; d:boolean;begin {перебираем все числа} for b:=1000 to 9999 do begin {сбрасываем массив цифр} for c:=0 to 9 do a[c]:=0; c:=b; {считаем цифры в числе} while c>0 do begin inc(a[c mod 10]); c:=c div 10; end; {Проверяем условие задачи} d:=false; for c:=0 to 9 do d:=d or (a[c]=3); {выводим результат} if d then begin write(b:6);readln;end; end;end.

<i>Здравствуйте, <b>Артемий Тотктонада</b>!</i>

Пример см. в приложении.
В примере реализован вывод всех четырех-значных чисел с тремя одинаковыми цифрами, но в неотсортированном виде. Если требуется также выводить и числа с четырьмя одинаковыми цифрами (где есть четыре одинаковых цифры, там всегда есть и три), то нужно просто удалить или закомментировать строчку "<code><b>if</b> (j <> i) <b>then</b></code>".

<em>Удачи!</em>

Приложение:
program q137701;uses Crt;var i, j, n: Integer; outStr: array[1..4] of Char;begin {Очистка экрана} ClrScr; {Выводим первое четырех-значное число} write (‘1000‘); {Выводим остальные числа} for i:= 1 to 9 do begin for j:= 0 to 9 do {Числа с четырьмя одинаковыми цифрами не выводим} if (j <> i) then begin for n:= 4 downto 1 do begin {Сумма j+n может равняться 1 только при j = 0 и n = 1} {Если число трех-значное (первая цифра ноль), то его не выводим} if (j + n = 1) then continue; {Заполняем выводимую строку одинаковыми цифрами} fillChar(outStr, 4, Char(Ord(‘0‘) + i)); {Заменяем единственную отличающуюся цифру} outStr[n]:= Char(Ord(‘0‘) + j); {Выводим число} write (‘, ‘, outStr); end; end; end; {Даем пользователю возможность насладиться результатом} writeln; write(‘Press any key...‘); readln;end.