En çok tekrar eden kelime

[Hakngnc]

Herkese Merhaba,

Excel'de A sutununda her satırda serbest metin yazdığını varsayalım. A sutununda en çok tekrar edilen kelime ve kaç kere tekrar ettiği, ikinci, üçüncü kelime nedir gibi bir çalışma yapılması mümkün müdür?

İyi günler

 

[tahsinanarat]

Sub mükerrer()
Dim hucre As Range, sat As Long, adr As String, tekrar As Long
Range("K2:L65536").ClearContents
sat = 2
For Each hucre In Range("A1:A100")
adr = Range(Cells(1, "K"), Cells(sat - 1, "K")).Address
If WorksheetFunction.CountIf(Range(adr), hucre.Value) = 0 Then
tekrar = WorksheetFunction.CountIf(Range("A1:A100"), hucre.Value)
Cells(sat, "K").Value = hucre.Value
Cells(sat, "L").Value = tekrar
sat = sat + 1
End If
Next
End Sub

 

[Hakngnc]

Teşekkür ederim değerli yanıtınız için, deneyeceğim.

 

[Korhan Ayhan]

Alternatif;

Ben kelime analizi yapmak istediğinizi anladım.

A sütunundaki verileri analiz ederek D-E sütunlarına listeler.

Option Explicit

Sub Kelime_Analizi()
    Dim Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Aranan As Variant, Y As Long, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:A" & Son).Value
    
    Range("D:E").ClearContents
    
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            Aranan = Split(Veri(X, 1), " ")
            
            For Y = LBound(Aranan) To UBound(Aranan)
                If Not .Exists(Aranan(Y)) Then
                    .Add Aranan(Y), 1
                Else
                    .Item(Aranan(Y)) = .Item(Aranan(Y)) + 1
                End If
            Next
        Next
    
        If .Count > 0 Then
            Range("D1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
            MsgBox "Kelime analizi tamamlanmıştır." & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        Else
            MsgBox "Analiz için uygun veri bulunamadı!", vbExclamation
        End If
    End With
End Sub

 

[tahsinanarat]

Option Explicit

Sub Kelime_Analizi()
   Dim Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Aranan As Variant, Y As Long, Zaman As Double
    Dim S1, S2
    Set S1 = Sheets("ANASAYFA")
    Set S2 = Sheets("Arşiv")

Zaman = Timer

    Son = S2.Cells(Rows.Count, 1).End(3).Row
   
    If Son = 1 Then Son = 2

    Veri = S2.Range("   B3:B" & Son).Value
   
    S1.Range("D2:E1000000").ClearContents
   
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            Aranan = Split(Veri(X, 1), "")
           
            For Y = LBound(Aranan) To UBound(Aranan)
                If Not .Exists(Aranan(Y)) Then
                    .Add Aranan(Y), 1
               Else
                    .Item(Aranan(Y)) = .Item(Aranan(Y)) + 1
                End If
            Next
        Next

        If .Count > 0 Then
            S1.Range("D2").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
            MsgBox "Kelime analizi tamamlanmıştır." & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        Else
            MsgBox "Analiz için uygun veri bulunamadı!", vbExclamation
        End If
    End With
End Sub

Sn. @Korhan Ayhan Hocam Ben Arşiv Adlı Sayfamdan getirmek için 4.mesajda verdiğiniz kodu bu şekilde değiştirip uyguladım, çalışmasında herhangi bir sıkıntı yok, ben ilaveten;
-Arşiv Adlı sayfamın H sutununda (verilen malzeme miktarı) bulunan sayıları da toplatarak yan sutuna (F sutunu) yazdırmak,
-Arşiv sayfamın B sutununda siciller, C sutunun da da adı ve soyadı şeklinde isimler var, B sutununda ilk bulduğu sicilin İsmini de getirmek istersem
kodda nasıl bir değişiklik yapmalıyım (İsim sayfa1 in C sutununa gelebilir.

Şimdeden teşekkürler hocam.

 

[Korhan Ayhan]

Örnek dosya paylaşarak açıklayınız.

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam örnek dosyam ektedir.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Veri_Analizi()
    Dim Veri As Variant, Son As Long, X As Long, Say As Long
    Dim S1 As Worksheet, S2 As Worksheet, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("ANASAYFA")
    Set S2 = Sheets("Arşiv")

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
  
    If Son <= 3 Then Son = 4

    Veri = S2.Range("A3:J" & Son).Value
  
    S1.Range("D2:G" & S1.Rows.Count).ClearContents
   
    ReDim Liste(1 To Son, 1 To 4)
   
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Not .Exists(Veri(X, 2)) Then
                Say = Say + 1
                .Add Veri(X, 2), Say
                Liste(Say, 1) = Veri(X, 2)
                Liste(Say, 2) = Veri(X, 3)
                Liste(Say, 3) = 1
                Liste(Say, 4) = Veri(X, 8)
            Else
                Liste(.Item(Veri(X, 2)), 3) = Liste(.Item(Veri(X, 2)), 3) + 1
                Liste(.Item(Veri(X, 2)), 4) = Liste(.Item(Veri(X, 2)), 4) + Veri(X, 8)
            End If
        Next

        If .Count > 0 Then
            S1.Range("D2").Resize(.Count, 4) = Liste
            MsgBox "Veri analizi tamamlanmıştır." & vbLf & vbLf & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        Else
            MsgBox "Analiz için uygun veri bulunamadı!", vbExclamation
        End If
    End With
End Sub

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam elinize sağlık tam istediğim gibi, Allah razı olsun. Hayırlı geceler diliyorum.

 

[Erdem Akdemir]

Merhaba,

ADO ile alternatif çözüm.

Sub kelimeler()

Range("H2:K" & Cells(Rows.Count, "H").End(3).Row + 1).ClearContents

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select SİCİL, ADI,COUNT(SİCİL),SUM(MİKTARI) FROM[Arşiv$A2:J65536]" & _
        "group by SİCİL, ADI order by SUM(MİKTARI) desc ,COUNT(SİCİL)"
Set rs = con.Execute(sorgu)

Range("H2").CopyFromRecordset rs

End Sub

 

[tahsinanarat]

Sn. @Erdem_34 çok teşekkür ederim, sanırım başlık sutunlarında boşluk olmaması gerekiyor, ADI VE SOYADI başlığını ADI olarak düzelttiğimde sonuç verdi. Elinize sağlık.

 

[Korhan Ayhan]

Ado kullanmak için belli kurallara uymanız gerekiyor.

Başlıklarda boşluk varsa köşeli parantez içinde yazarak sonuç alabilirsiniz.

[ADI SOYADI]

 

[tahsinanarat]

Teşekkürler Korhan hocam.