listbox sorunu

[sr1111]

merhaba
listboxa aldigim kelimelerin aynisindan kac tane varsa yanina yazmasini istiyorum nasil yaparim.

elma 5 (eger 5 elma varsa)
armut 3
limon 2

soyle bir sey yaptim ama calistiramadim.

begin
for i:= 0 to wordlist.items.count-1 do
begin
wordlist.Items.Strings:=wordlist.Items.Strings+ ' ' + inttostr(TCount(wordlist.Items.Objects).count);

[Lanista]

Fazla düşünmeden, belkide uzun yoldan aşağıdaki şekilde yaptım, daha kolay bir yolu mutlaka vardır ama en iyi kod çalışan kod.

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
var
  I, I2, Adet: Integer;
  Adetler: TStringList;
begin
  Adetler := TStringList.Create;
  for I := 0 to ListBox1.Items.Count-1 do
  begin
     Adet := 0;
     for I2 := 0 to ListBox1.Items.Count-1 do
     begin
       if ListBox1.Items.Strings[I] = ListBox1.Items.Strings[I2] then
         Inc(Adet);
     end;
     Adetler.Add(Inttostr(Adet));
  end;
  for I := 0 to ListBox1.Items.Count-1 do
  begin
    ListBox1.Items.Strings[I] := ( ListBox1.Items.Strings[I] + ' ' + Adetler.Strings[I]);
  end;
  Adetler.Free;
end;

[sr1111]

tekrar tesekkur ederim Lanista calisti.

[sr1111]

300 bin kayitta mesela delphi 1 saatte yapiyor. stringlistede ayni sonuc cok gec oluyor..
asagidaki 2 excel macrosuda ayni seyi 1-2 saniyede yapiyor. bunun hizli bir yontemi yok mu delphide.
Veya excel macrsunu ceviremezmiyiz.

Sub birinci formul()
Dim z As Object, hcr As Range
Application.ScreenUpdating = False
Range("C:D").ClearContents
Set z = CreateObject("Scripting.dictionary")
For Each hcr In Range("A1:A" & Cells(65536, "A").End(xlUp).Row)
If Not z.exists(hcr.Value) Then
z.Add hcr.Value, 1
Else
z.Item(hcr.Value) = z.Item(hcr.Value) + 1
End If
Next
[C1].Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
Application.ScreenUpdating = True
End Sub



Sub ikinciformul()
[d2:e65536].ClearContents

Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = TextCompare

For Each ALAN In [a:a].SpecialCells(xlCellTypeConstants, 23)
ekle = ALAN.Value
If dic.Exists(ekle) Then
w = dic(ekle)
dic(ekle) = w + 1
Else
w = 1
dic.Add ekle, w
End If
Next

dizi = dic.Keys
Range("d2").Resize(UBound(dizi) + 1) = WorksheetFunction.Transpose(dizi)
'For x = 0 To UBound(dizi)
' Cells(x + 2, 4) = dizi(x)
'Next
dizi = dic.Items
Range("e2").Resize(UBound(dizi) + 1) = WorksheetFunction.Transpose(dizi)
'For x = 0 To UBound(dizi)
' Cells(x + 2, 5) = dizi(x)
'Next
[d:e].Sort Key1:=[d2], Order1:=xlAscending, Header:=xlGuess
Application.ScreenUpdating = True
Erase dizi
Set dic = Nothing
End Sub

[mkysoft]

Excel makrosunda olduğu gibi önce kelimeleri sıralamalısınız. Aynı kelimeler alt alta geldiğinde hızlıca sayabileceksiniz. Çok fazla kayıt olduğu durumlarda stringlist kullanmanız iyi olur. Hatta array kullanırsanız daha da hızlı olacaktır.

[sr1111]

str.sort; ile ettim zaten, sonra nasil döngü kurmam lazim.

[SimaWB]

Daha önceki sorunuzda @ikutluay'ın da bahsettiği gibi sıralama algoritmalarını biraz araştırmalısınız.