Подсчет количества повторов в StringList'e и заполнение столбца StringGrid

var sheet : OLEVariant; // Присвоенный лист Excel
 
procedure Unique(var StringList:TStringList; Duplicates:boolean);
var t : integer;
begin
StringList := TStringList.Create();
StringList.clear;
StringList.Sorted := True;
if duplicates = true then StringList.Duplicates := dupAccept else StringList.Duplicates := dupIgnore;
t := 2;
while sheet.cells[t,12].Value <> '' do
begin
application.ProcessMessages;
StringList.add( sheet.cells[t,12]);
RatingForm.progressbar1.Position := RatingForm.progressbar1.Position +7;
t := t + 1;
end;
end;
 
 
procedure TRatingForm.FormActivate(Sender: TObject);
var i,e, res:integer;
sl, sl2:tstringlist;
begin
for i := 1 to StringGrid1.RowCount - 1
do StringGrid1.Rows[i].Clear;
progressbar1.Position := 0;
progressbar1.Visible := true;
progressbar1.Max := sheet.rows.count;
stringgrid1.DefaultColWidth := trunc(ratingform.ClientWidth / 3) -7 ;
unique(sl,false);
stringgrid1.RowCount := sl.Count + 1;
unique(sl2,true);
e := 0;
i := 0;
res := 0;
while i <> sl.Count-1 do
begin
res := 0;
while sl[i] = sl2[e]  do
                      begin
                      inc(res);
                      inc(e);
                      end;
stringgrid1.cells[2,i+1] := inttostr(res);
inc(i);
end;
 
for e := 0 to Sl.Count-1 do
begin
application.ProcessMessages;
stringgrid1.cells[1,e+1] := sl[e];
stringgrid1.cells[0,e+1] := inttostr(e+1);
end;
progressbar1.Visible := false;
//SortStringGrid(stringgrid1,2);
end;

while i <> sl.Count-1 do

while i < sl.Count do

for i := 0 to sl.Count - 1 do

{Вертикальная сортировка таблицы по значениям ячеек в столбце с заданным индексом.
При сортировке выполняются перестановки строк целиком.
Сортировка производится согласно кодировочной таблице.
Фиксированные строки сортировке не подвергаются.}
procedure SgSort(aSg : TStringGrid; const aCol : Integer);
var
  SlSort, SlRow : TStringList;
  i, j : Integer;
begin
  //Сортируемый список.
  SlSort := TStringList.Create;
 
  {Добавляем в сортируемый список пары: "строка - объект".
  В качестве строки будем записывать значения ячеек того столбца, по которому
  надо провести сортировку. А в качестве объекта будем присоединять копии
  соответствующих строк таблицы. Фиксированные строки }
  for i := aSg.FixedRows to aSg.RowCount - 1 do
  begin
    //Создаём контейнер для копии строки таблицы.
    SlRow := TStringList.Create;
    //Копируем строку таблицы в контейнер.
    SlRow.Assign(aSg.Rows[i]);
    //Добавляем в сортируемый список пару:
    //строка - строка из ячейки целевого столбца;
    //объект - контейнер, содержащий копию строки таблицы.
    SlSort.AddObject(aSg.Cells[aCol, i], SlRow);
  end;
 
  //Сортируем столбец.
  SlSort.Sort;
 
  //Возвращаем в таблицу строки, отсортированные по столбцу с номером aCol.
  j := 0;
  for i := aSg.FixedRows to aSg.RowCount - 1 do
  begin
    //Берём очередной контейнер.
    SlRow := Pointer(SlSort.Objects[j]);
    //Записываем содержимое контейнера в строку таблицы.
    aSg.Rows[i].Assign(SlRow);
    //Уничтожаем контейнер.
    FreeAndNil(SlRow);
    //Следующий индекс списка.
    Inc(j);
  end;
 
  //Уничтожаем сортируемый список.
  FreeAndNil(SlSort);
end;
 
//Пример использования.
procedure TForm1.Button1Click(Sender: TObject);
var
  Col : Integer
begin
  //В Edit1.Text записан индекс столбца таблицы, по которому требуется
  //выполнить сортировку.
  Col := StrToInt(Edit1.Text)
  SgSort(StringGrid1, Col);
end;

{Вертикальная сортировка таблицы по значениям ячеек в столбце с заданным индексом.
При сортировке выполняются перестановки строк целиком.
Сортировка производится согласно кодировочной таблице.
Фиксированные строки сортировке не подвергаются.}
procedure SgSort(aSg : TStringGrid; const aCol : Integer);
var
  SlSort, SlRow : TStringList;
  i, j : Integer;
begin
  //Сортируемый список.
  SlSort := TStringList.Create;
  SlSort.Duplicates := dupAccept;
  SlSort.Sorted := True;
 
  {Добавляем в сортируемый список пары: "строка - объект".
  В качестве строки будем записывать значения ячеек того столбца, по которому
  надо провести сортировку. А в качестве объекта будем присоединять копии
  соответствующих строк таблицы. Фиксированные строки исключаем из стортировки.
  Так, как для списка включен режим сортировки (SlSort.Sorted := True), то
  добавляемые элементы будут размещаться в нём в соответствии с правилом
  сортировки. Т. е. список всегда будет находится в отсортированном состоянии.}
  for i := aSg.FixedRows to aSg.RowCount - 1 do
  begin
    //Создаём контейнер для копии строки таблицы.
    SlRow := TStringList.Create;
    //Копируем строку таблицы в контейнер.
    SlRow.Assign(aSg.Rows[i]);
    //Добавляем в сортируемый список пару:
    //строка - строка из ячейки целевого столбца;
    //объект - контейнер, содержащий копию строки таблицы.
    SlSort.AddObject(aSg.Cells[aCol, i], SlRow);
  end;
 
  //Возвращаем в таблицу строки, отсортированные по столбцу с номером aCol.
  j := 0;
  for i := aSg.FixedRows to aSg.RowCount - 1 do
  begin
    //Берём очередной контейнер.
    SlRow := Pointer(SlSort.Objects[j]);
    //Записываем содержимое контейнера в строку таблицы.
    aSg.Rows[i].Assign(SlRow);
    //Уничтожаем контейнер.
    FreeAndNil(SlRow);
    //Следующий индекс списка.
    Inc(j);
  end;
 
  //Уничтожаем сортируемый список.
  FreeAndNil(SlSort);
end;

for i := 0 to sl.Count - 1 do
begin
  res := 0;
  for e := 0 to sl2.Count - 1 do
    if sl[i] = sl2[e] then
      Inc(res);
  stringgrid1.cells[2,i+1] := inttostr(res);
end;

for e := 0 to Sl.Count-1 do
begin
application.ProcessMessages;
stringgrid1.cells[1,e+1] := sl[e];       //при е = Sl.Count-1 будет обращение к строке с номером Sl.Count
stringgrid1.cells[0,e+1] := inttostr(e+1);

implementation
 
{$R *.dfm}
 
uses
  Math;
 
{Функции типа TStringListSortCompare для сравнения элементов при сортировке.
 
Этот тип определён в модуле Classes таким образом:
type TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
Логика работы функции должна быть такой:
1. Если элемент с индексом Index1 должен следовать до элемента с индексом
   Index2, то функция должна вернуть значение меньшее нуля.
2. Если элемент с индексом Index1 должен следовать после элемента с индексом
   Index2, то функция должна вернуть значение большее нуля.
3. Если элементы с индексами Index1 и Index2 равны, то функция
   должна вернуть значение равное нулю.}
 
{Функция сравнения для сортировки строк по возрастанию.}
function CompStrAsc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  S1, S2 : String;
begin
  S1 := aSl[aIndex1];
  S2 := aSl[aIndex2];
  if S1 < S2 then
    Result := -1
  else if S1 > S2 then
    Result := 1
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки строк по убыванию.}
function CompStrDesc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  S1, S2 : String;
begin
  S1 := aSl[aIndex1];
  S2 := aSl[aIndex2];
  if S1 > S2 then
    Result := -1
  else if S1 < S2 then
    Result := 1
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки чисел по возрастанию.
Если элемент не является представлением числа, то он попадёт в конец списка
без сортировки.}
function CompNumAsc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  N1, N2 : Extended;
begin
  //Используя значение = Infinity, мы обеспечиваем режим, при котором
  //НЕчисловые значения будут попадать в конец списка.
  N1 := StrToFloatDef(aSl[aIndex1], Infinity);
  N2 := StrToFloatDef(aSl[aIndex2], Infinity);
  if N1 < N2 then
    Result := -1
  else if N1 > N2 then
    Result := 1
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки чисел по убыванию.
Если элемент не является представлением числа, то он попадёт в конец списка
без сортировки.}
function CompNumDesc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  N1, N2 : Extended;
begin
  //Используя значение = -Infinity, мы обеспечиваем режим, при котором
  //НЕчисловые значения будут попадать в конец списка.
  N1 := StrToFloatDef(aSl[aIndex1], -Infinity);
  N2 := StrToFloatDef(aSl[aIndex2], -Infinity);
  if N1 > N2 then
    Result := -1
  else if N1 < N2 then
    Result := 1
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки чисел и строк по возрастанию.
Порядок следования: сначала - числа, потом - строки.}
function CompNumStrAsc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  N1, N2 : Extended;
begin
  //Используя значение = Infinity, мы обеспечиваем режим, при котором
  //НЕчисловые значения будут попадать в конец списка.
  N1 := StrToFloatDef(aSl[aIndex1], Infinity);
  N2 := StrToFloatDef(aSl[aIndex2], Infinity);
  if N1 < N2 then
    Result := -1
  else if N1 > N2 then
    Result := 1
  else if (N1 = N2) and (N1 = Infinity) then
    //Если оба элемента не являются представлениями чисел, то применяем
    //соответствующую функцию сравнения строковых элементов.
    Result := CompStrAsc(aSl, aIndex1, aIndex2)
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки чисел и строк по убыванию.
Порядок следования: сначала - числа, потом - строки.}
function CompNumStrDesc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  N1, N2 : Extended;
begin
  //Используя значение = -Infinity, мы обеспечиваем режим, при котором
  //НЕчисловые значения будут попадать в конец списка.
  N1 := StrToFloatDef(aSl[aIndex1], -Infinity);
  N2 := StrToFloatDef(aSl[aIndex2], -Infinity);
  if N1 > N2 then
    Result := -1
  else if N1 < N2 then
    Result := 1
  else if (N1 = N2) and (N1 = -Infinity) then
    //Если оба элемента не являются представлениями чисел, то применяем
    //соответствующую функцию сравнения строковых элементов.
    Result := CompStrDesc(aSl, aIndex1, aIndex2)
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки строк и чисел по возрастанию.
Порядок следования: сначала - строки, потом - числа.}
function CompStrNumAsc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  N1, N2 : Extended;
begin
  //Используя значение = -Infinity, мы обеспечиваем режим, при котором
  //НЕчисловые значения будут попадать в начало списка.
  N1 := StrToFloatDef(aSl[aIndex1], -Infinity);
  N2 := StrToFloatDef(aSl[aIndex2], -Infinity);
  if N1 < N2 then
    Result := -1
  else if N1 > N2 then
    Result := 1
  else if (N1 = N2) and (N1 = -Infinity) then
    //Если оба элемента не являются представлениями чисел, то применяем
    //соответствующую функцию сравнения строковых элементов.
    Result := CompStrAsc(aSl, aIndex1, aIndex2)
  else
    Result := 0;
end;
 
{Функция сравнения для сортировки строк и чисел по убыванию.
Порядок следования: сначала - строки, потом - числа.}
function CompStrNumDesc(aSl: TStringList; aIndex1, aIndex2: Integer) : Integer;
var
  N1, N2 : Extended;
begin
  //Используя значение = Infinity, мы обеспечиваем режим, при котором
  //НЕчисловые значения будут попадать в начало списка.
  N1 := StrToFloatDef(aSl[aIndex1], Infinity);
  N2 := StrToFloatDef(aSl[aIndex2], Infinity);
  if N1 > N2 then
    Result := -1
  else if N1 < N2 then
    Result := 1
  else if (N1 = N2) and (N1 = Infinity) then
    //Если оба элемента не являются представлениями чисел, то применяем
    //соответствующую функцию сравнения строковых элементов.
    Result := CompStrDesc(aSl, aIndex1, aIndex2)
  else
    Result := 0;
end;
 
{Вертикальная сортировка таблицы по значениям ячеек в столбце с заданным индексом.
Сортировка выполняется согласно правилу, заложенному в функции aProcComp().
Фиксированные строки сортировке не подвергаются.
Примеры вызова:
Col := IntToStr(Edit1.Text); //Индекс столбца, по которому надо выполнить сортировку.
1. SgSort(StringGrid1, Col, CompStrAsc);  - Сортировка строк по возрастанию.
2. SgSort(StringGrid1, Col, CompStrDesc); - Сортировка строк по убыванию.
3. SgSort(StringGrid1, Col, CompNumAsc);  - Сортировка чисел по возрастанию. Строки записываются в конц списка без сортировки.
4. SgSort(StringGrid1, Col, CompNumDesc); - Сортировка чисел по убыванию. Строки записываются в конц списка без сортировки.
5. SgSort(StringGrid1, Col, CompNumStrAsc);  - Сортировка чисел и строк по возрастанию. Сначала - числа, потом - строки.
6. SgSort(StringGrid1, Col, CompNumStrDesc); - Сортировка чисел и строк по убыванию. Сначала - числа, потом - строки.
7. SgSort(StringGrid1, Col, CompStrNumAsc);  - Сортировка строк и чисел по возрастанию. Сначала - строки, потом - числа.
8. SgSort(StringGrid1, Col, CompStrNumDesc); - Сортировка строк и чисел по убыванию. Сначала - строки, потом - числа.}
procedure SgSort(aSg : TStringGrid; const aCol : Integer; const aProcComp : TStringListSortCompare);
var
  SlSort, SlRow : TStringList;
  i, j : Integer;
begin
  //Сортировочный список.
  SlSort := TStringList.Create;
 
  {Добавляем в сортировочный список пары: "строка - объект".
  В качестве строки будем записывать значения ячеек того столбца, по которому
  надо провести сортировку. А в качестве объекта будем присоединять копии
  соответствующих строк таблицы. Фиксированные строки исключаем из сортировки.}
  for i := aSg.FixedRows to aSg.RowCount - 1 do
  begin
    //Создаём контейнер для копии строки таблицы.
    SlRow := TStringList.Create;
    //Копируем строку таблицы в контейнер.
    SlRow.Assign(aSg.Rows[i]);
    //Добавляем в сортировочный список пару:
    //строка - значение ячейки целевого столбца;
    //объект - контейнер (список), содержащий копию всей табличной строки.
    SlSort.AddObject(SlRow[aCol], SlRow); //Или так: SlSort.AddObject(aSg.Cells[aCol, i], SlRow);
  end;
 
  //Сортируем список.
  SlSort.CustomSort(aProcComp);
 
  //Возвращаем в таблицу отсортированные строки.
  j := 0;
  for i := aSg.FixedRows to aSg.RowCount - 1 do
  begin
    //Берём очередной контейнер.
    SlRow := Pointer(SlSort.Objects[j]);
    //Записываем содержимое контейнера в строку таблицы.
    aSg.Rows[i].Assign(SlRow);
    //Уничтожаем контейнер.
    FreeAndNil(SlRow);
    //Следующий индекс списка.
    Inc(j);
  end;
 
  //Уничтожаем сортируемый список.
  FreeAndNil(SlSort);
end;
 
//Пример использования.
procedure TForm1.Button1Click(Sender: TObject);
var
  Col : Integer;
begin
  //В Edit1.Text записан индекс столбца, по которому требуется выполнить сортировку.
  Col := StrToInt(Edit1.Text);
  if (Col < 0) or (Col > (StringGrid1.ColCount - 1)) then
  begin
    MessageBox(Handle, 'Индекс задан неверно. Действие отменено.', 'Ошибка!',
      MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
 
  //Вертикальная сортировка таблицы.
  if RadioButton1.Checked then //Строки по возрастанию.
    SgSort(StringGrid1, Col, CompStrAsc)
  else if RadioButton2.Checked then //Строки по убыванию.
    SgSort(StringGrid1, Col, CompStrDesc)
  else if RadioButton3.Checked then //Числа по возрастанию.
    SgSort(StringGrid1, Col, CompNumAsc)
  else if RadioButton4.Checked then //Числа по убыванию.
    SgSort(StringGrid1, Col, CompNumDesc)
  else if RadioButton5.Checked then //Числа и строки по возрастанию.
    SgSort(StringGrid1, Col, CompNumStrAsc)
  else if RadioButton6.Checked then //Числа и строки по убыванию.
    SgSort(StringGrid1, Col, CompNumStrDesc)
  else if RadioButton7.Checked then //Строки и числа по возрастанию.
    SgSort(StringGrid1, Col, CompStrNumAsc)
  else if RadioButton8.Checked then //Строки и числа по убыванию.
    SgSort(StringGrid1, Col, CompStrNumDesc);
end;
 
end.

procedure Unique(var StringList:TStringList;col:integer);
var t,p : integer;
begin
StringList := TStringList.Create();
StringList.clear;
StringList.Sorted := True;
StringList.Duplicates := dupIgnore;
p := sheet.Range[Char(96 + col) + IntToStr(65536)].end[3].Rows.Row;
t := 2;
while t <> p  do
begin
application.ProcessMessages;
StringList.add(sheet.cells[t,col]);
inc(t);
end;
end;
 
procedure consign;
var
per,pol:tstringlist;
er,de:integer;
begin
Unique(per,7);
for er := 1 to per.Count-1 do
begin //Заполнение списка ПЕРЕВОЗЧИК
application.ProcessMessages;
mainform.ComboBox1.Items.Add(per[er]);
end;
Unique(pol,8);
for de := 1 to pol.Count-1 do
begin //Заполнение списка ПОЛУЧАТЕЛЬ
application.ProcessMessages;
mainform.ComboBox2.Items.Add(pol[de]);
end;
end;

for er := 1 to per.Count-1 do

for de := 1 to pol.Count-1 do

while t <> p  do

while t <= p  do

var
  ...
  S : String;
begin
...
  t := 2;
  while t <= p  do
  begin
    Application.ProcessMessages;
    S := sheet.cells[t,col].Text;
    if S <> '' then //Записываем только непустые строки.
      StringList.Add(S);
    Inc(t);
  end;
...

for er := 0 to per.Count-1 do
...
for de := 0 to pol.Count-1 do