Ciao Bluepill,
=============
ho un problema da affrontare e volevo magari qualche spunto da parte
vostra a livello piu che altro concettuale (per ora).
ho dei testi e vorrei estrarre da ognuno di questi testi, una lista
delle singole parole di cui è composto aggregate per parola e con un
numero affianco per l'occorrenza associata.
Non mi viene in mente da dove partire onestamente.
immagino di copiare e incollare il testo in un foglio excel. si spezzera
probilmente su piu celle.
ORa, vorrei analizzare il testo con una funzione, o forse un vba?
immagino che prima di tutto si trattera di estrarre tutte le parole e
poi di ordinarle e poi contarle con la sua funzione...
qualche suggerimento?
l'output dovrebbe essere una colonna con le singole parole espresse una
volta sola e un'altra colonna con il numero della loro frequenza
=============
In un modulo standard (vedi di sotto),
prova:
'==========>>
Option Explicit
Public Sub FindUniques(Optional WB As Workbook, _
Optional SH As Worksheet, _
Optional Rng As Range)
'///////////////////////////////////////////
'Restituisce il numero di volte que si trova
'ogni valore unico negli intervalli di interesse
'///////////////////////////////////////////
Dim rCell As Range
Dim aCell As Range
Dim Col As Collection
Dim myArr() As Variant
Dim i As Long
Dim j As Long
Dim msg As String
If WB Is Nothing Then
Set WB = ActiveWorkbook
End If
If SH Is Nothing Then
Set SH = WB.ActiveSheet
End If
If Rng Is Nothing Then
If SH.Name = ActiveSheet.Name Then
If TypeOf Application.Selection Is Excel.Range Then
Set Rng = Application.Selection
Else
Set Rng = SH.UsedRange
End If
Else
Set Rng = SH.UsedRange
End If
End If
If Not Intersect(Rng, SH.UsedRange) Is Nothing Then
Set Rng = Intersect(Rng, SH.UsedRange)
Else
Set Rng = SH.UsedRange
End If
Set Col = New Collection
If Rng.Count = 1 Then
Set Rng = SH.UsedRange
MsgBox Prompt:="Non hai fatto una selezione valida" _
& vbNewLine _
& "Questa routine richiede una " & _
"selezezione di piu' celle", _
Buttons:=vbInformation, _
Title:="Selection Error!"
Exit Sub
End If
'\\ Add cells to the collection.
'\\ Duplicates create an error and are not added
For Each rCell In Rng.Cells
With rCell
If Not IsEmpty(.Value) Then
On Error Resume Next
Col.Add .Value, CStr(.Value)
On Error GoTo 0
End If
End With
Next rCell
On Error Resume Next
'\\ Redim the array to fit the collection
ReDim myArr(1 To Col.Count, 1 To 2)
'\\ Fill the array with the collection items
'\\ and their occurrences
For i = LBound(myArr, 1) To UBound(myArr, 1)
j = 0
myArr(i, 1) = Col.Item(i)
For Each rCell In Rng.Cells
With rCell
If .Value = myArr(i, 1) Then
j = j + 1
End If
End With
Next rCell
myArr(i, 2) = j
Next i
' '\\ Print the array to make sure it worked
' For i = LBound(myArr, 1) To UBound(myArr, 1)
' 'Debug.Print myArr(i, 1), myArr(i, 2)
' msg = msg & myArr(i, 1) _
' & vbTab & myArr(i, 2) _
' & vbNewLine
' Next i
On Error GoTo 0
If Len(msg) = 0 Then
msg = "Nessun valore trovato!"
End If
MsgBox Prompt:=msg, _
Buttons:=vbInformation, _
Title:="Unique Values Report"
XIT:
'\\ Clean up
Set rCell = Nothing
Set Rng = Nothing
Set Col = Nothing
End Sub
'<<==========
Si chiamerebbe la suddetta routine
con una macro del genere:
'==========>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Set WB = Workbooks("Pippo.xls") '<<=== da CAMBIARE
Set SH = WB.Sheets("Foglio1") '<<=== da CAMBIARE
Set Rng = SH.Range("C8:C16,G10:G11") '<<=== da CAMBIARE
Call FindUniques(WB, SH, Rng)
End Sub
'<<==========
Per utilizzare questa routine:
Alt-F11 per aprire l'Editor di VBA
Menu | Inserisci | Modulo
Incolla il suddetto codice
Alt-F11 per tornare in Excel
Alt-F8
Seleziona "Tester"
Esegui
---
Regards.
Norman