<code lang="Visual Basic">
Option Explicit

Private mytotals(1 To 100) As Integer
Private items(1 To 100) As String
Private itemcount As Integer


Function Total(cells As Range)
Dim cell
Dim item As String
Dim posInItems As Integer
itemcount = 0


Dim totalscount As Integer
Dim counter As Integer
counter = 0

Dim lastPos As Integer
lastPos = 1

Dim i, j As Integer
Dim ch As String
Dim myDLM As String
myDLM = "|"
    
For Each cell In cells
    Dim szText As String
    szText = cell.Value
    
    lastPos = 1
    For i = 1 To Len(szText)
        ch = Mid(szText, i, 1)
        If ch = myDLM Then
            
            item = (Mid(szText, lastPos, i - lastPos))
            counter = counter + 1
            
            lastPos = i + 1

            posInItems = inArray(item, items(), itemcount)
            If (posInItems = 0) Then
                itemcount = itemcount + 1
                Let items(itemcount) = item
                mytotals(itemcount) = 1
              
            Else
                mytotals(posInItems) = mytotals(posInItems) + 1
            End If
            
            
        ElseIf i = Len(szText) Then

            item = Mid(szText, lastPos, i + 1 - lastPos)
            counter = counter + 1
            
            posInItems = inArray(item, items(), itemcount)
            If (posInItems = 0) Then
                itemcount = itemcount + 1
                Let items(itemcount) = item
                mytotals(itemcount) = 1

            Else
                mytotals(posInItems) = mytotals(posInItems) + 1
            End If
        End If
        
    Next i
Next cell

Call SortData(itemcount)
For j = 1 To itemcount
    Total = Total & Format((mytotals(j) / counter * 100), "00.0") & "% - " & mytotals(j) & ": " & items(j) & vbLf
Next j

Total = Total & "---" & vbLf & counter

End Function

Private Function inArray(str As String, arr() As String, n As Integer)
    Dim i As Integer
    Dim found As Boolean
    found = False
    
    inArray = 0
    For i = 1 To n
        If str = arr(i) Then
            found = True
            inArray = i

        End If
    Next i
    
End Function


Private Sub SwapInt(a As Integer, b As Integer)
    Dim temp As Single
    temp = a
    a = b
    b = temp
End Sub

Private Sub SwapStr(a As String, b As String)
    Dim temp As String
    temp = a
    a = b
    b = temp
End Sub

Private Sub SwapData(index As Integer)
    Call SwapStr(items(index), items(index + 1))
    Call SwapInt(mytotals(index), mytotals(index + 1))
End Sub

Private Sub SortData(size As Integer)
    Dim passNum As Integer, index As Integer
    For passNum = 1 To size - 1
        For index = 1 To size - passNum
            If mytotals(index) < mytotals(index + 1) Then
                Call SwapData(index)
            End If
        Next index
    Next passNum
End Sub
</code>