Sub StatisticForEachWord()
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim lastRow As Long
    Dim sourceRange As Range
    Dim cell As Range
    Dim wordsDict As Object
    Dim wordCombination As String
    Dim clicks As Double
    
    ' Set the source and destination sheets
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1") ' Change to your source sheet name
    Set destinationSheet = ThisWorkbook.Sheets("Sheet2") ' Change to your destination sheet name
    
    ' Find the last row in column I
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "I").End(xlUp).Row
    
    ' Set the source range
    Set sourceRange = sourceSheet.Range("I2:K" & lastRow) ' Assuming data starts from row 2
    
    ' Create a dictionary to store words and their statistics
    Set wordsDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through each cell in the source range
    For Each cell In sourceRange.Rows
        wordCombination = cell.Cells(1, 1).Value
        clicks = cell.Cells(1, 3).Value ' Assuming clicks are in column K
        
        ' Split word combination into individual words
        Dim words() As String
        words = Split(wordCombination, " ")
        
        ' Create a dictionary to track unique words in this cell
        Dim cellWordsDict As Object
        Set cellWordsDict = CreateObject("Scripting.Dictionary")
        
        For Each word In words
            word = Trim(word)
            If Not cellWordsDict.Exists(word) Then
                cellWordsDict.Add word, True
                If Not wordsDict.Exists(word) Then
                    wordsDict.Add word, clicks ' Total Clicks
                Else
                    wordsDict(word) = wordsDict(word) + clicks
                End If
            End If
        Next word
    Next cell
    
    ' Clear existing data in destination sheet
    destinationSheet.Cells.Clear
    
    ' Set header for destination sheet
    destinationSheet.Cells(1, 1).Value = "Word"
    destinationSheet.Cells(1, 2).Value = "Total Clicks"
    
    ' Loop through dictionary and paste results to destination sheet
    Dim rowIndex As Long
    rowIndex = 2
    
    For Each word In wordsDict.keys
        Dim totalClicks As Double
        totalClicks = wordsDict(word)
        
        ' Paste word and total clicks in destination sheet
        destinationSheet.Cells(rowIndex, 1).Value = word
        destinationSheet.Cells(rowIndex, 2).Value = totalClicks
        
        rowIndex = rowIndex + 1
    Next word
End Sub