Ускорить поиск Excel

[SolovejK]

Можно как нибудь ускорить следующий код?
Если файлов много, то поиск очень долгий.

procedure TForm1.Button1Click(Sender: TObject);
var
  addr1 : OleVariant;
  str, result: string;
  sr : TSearchRec;
  FindRes, p: Integer;

begin
  FindRes := FindFirst(ExtractFilePath(Application.ExeName) + '*.xml',faAnyFile,sr); // задание условий поиска и начало поиска
  While FindRes = 0 do // пока мы находим файлы, выполняем цикл
    begin
      str:=sr.Name;       //из xml файлов вида ABCDFE5_123456.XML оставляю только цифры, которые есть в Excel файле
      p:=pos('_',str);
      delete(str,1,p);
      Delete(Str,Pos('.',Str),Length(Str));

      r := WorkSheet1.UsedRange[0].Find
     (str,
      EmptyParam,
      xlValues,
      xlPart,
      xlByRows,
      xlNext,
      False,
      False,
      EmptyParam);

      r.Activate;

      addr1 := R.Address[False, False, xlA1, EmptyParam, EmptyParam];
      result:=addr1;
      delete(result,1,1);

      ListBox1.Items.Add(sr.Name);      //вывожу список найденных файлов
      ListBox3.Items.Add(Worksheet1.Cells.item[strtoint(result),12].Value2); // вывожу названия, которые соответствуют цифрам

      FindRes:=FindNext(sr);
    end;
  FindClose(SR);
end;