Moderatori: Anthony47, Flash30005
Function wComm(ByVal primo As String, ByVal secondo As String) As Boolean
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=98797
'Uso:
' =WCOMM(PrimaFrase;SecondaFrase)
' restituisce Vero se hanno almeno una parola in comune
' per parola si intende una stringa separata nella frase almeno da uno spazio
'
Dim my1Split, my2Split, I As Long, J As Long
my1Split = Split(primo, " "): my2Split = Split(secondo, " ")
'DLen = 0
For I = 0 To UBound(my1Split)
For J = 0 To UBound(my2Split)
If Len(my1Split(I)) > 2 And Len(my2Split(J)) > 2 Then
If UCase(my1Split(I)) = UCase(my2Split(J)) Then
wComm = True: Exit Function
End If
End If
Next J
Next I
End Function
=WCOMM(PrimaFrase;SecondaFrase)
=TROVA("ros";A2)
Anthony47 ha scritto:In alternativa si puo' usare una Funzione ad hoc; poiche' wittelsbach non si e' sciupato a definire quali regole vuoi utilizzare mi sono inventato che basta ci sia una parola (stringa separata da uno spazio) lunga almeno 3 caratteri in comune per avere esito positivo. Per questo inserisci in un Modulo standard il seguente codice:Poi nel tuo foglio userai una formula del tipo
- Codice: Seleziona tutto
Function wComm(ByVal primo As String, ByVal secondo As String) As Boolean
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=98797
'Uso:
' =WCOMM(PrimaFrase;SecondaFrase)
' restituisce Vero se hanno almeno una parola in comune
' per parola si intende una stringa separata nella frase almeno da uno spazio
'
Dim my1Split, my2Split, I As Long, J As Long
my1Split = Split(primo, " "): my2Split = Split(secondo, " ")
'DLen = 0
For I = 0 To UBound(my1Split)
For J = 0 To UBound(my2Split)
If Len(my1Split(I)) > 2 And Len(my2Split(J)) > 2 Then
If UCase(my1Split(I)) = UCase(my2Split(J)) Then
wComm = True: Exit Function
End If
End If
Next J
Next I
End Function
- Codice: Seleziona tutto
=WCOMM(PrimaFrase;SecondaFrase)
Restituira' Vero se le due frasi hanno almeno una parola in comune.
Per le mie definizioni, "amore" e "d'amore" non danno esito positivo; ma "amore" e "d' amore" (notare lo spazio
in "d' amore") si.
=WordIntersect(A1;B1)
=WordIntersect(A1;B1;0;VERO)
=WordIntersect(A1;B1;1)
=WordIntersect(A1;B1;1;FALSO)
=WordIntersect(A1;B1;;FALSO)
'----------------------------------------------------------------------------------------------------
' Function : WordIntersect(Arg1, Arg2, [Arg3=vbTextCompare], [Arg4 = VbTriState ])
' Author : scossa
' Date : 26/07/2013
' Purpose : confronta le singole parole di due stringhe
' e restituisce la parola se almeno una è in comune
' Per default il confronto non distingue tra maiuscole e minuscole,
' ma impostando il terzo argomento a 0 o FALSO la distinzione viene fatta.
' Se NON viene trovata una corrispondenza:
' - se il quarto argomento è omesso o è -2 viene restituita l'errore #N/D
' - se il quarto argomento è 0 o FALSO viene restituito FALSO
' - se il quarto argomento è VERO o un numero > 0 viene restituito ""
' Se VIENE trovata una corrispondenza:
' - se il quarto argomento è omesso o è -2 viene restituita la parola,
' altrimenti viene restituito VERO
'----------------------------------------------------------------------------------------------------
'
Function WordIntersect(ByVal sSentence1 As String, _
ByVal sSentence2 As String, _
Optional ByVal vbCompText As VbCompareMethod = vbTextCompare, _
Optional ByVal bRetErr As VbTriState = vbUseDefault) As Variant
Dim arrSentence1() As String
Dim j As Long
arrSentence1 = Split(Replace(sSentence1, "'", " "), " ")
sSentence2 = "#" & Replace(Replace(sSentence2, "'", " "), " ", "#") & "#"
'se non trova corrispondenza:
Select Case bRetErr
Case vbUseDefault 'argomento mancante o -2
'restituisce l'errore #N/D:
WordIntersect = CVErr(Excel.xlErrNA)
Case vbFalse ' 0 o FALSO
'restituisce FALSO
WordIntersect = False
Case Else 'VERO o qualsiasi altro valore
'restitutisce ""
WordIntersect = ""
End Select
For j = 0 To UBound(arrSentence1)
If InStr(1, sSentence2, "#" & arrSentence1(j) & "#", Abs(vbCompText)) > 0 Then
'se l'argomento bRetErr manca o è -2 restituisce la prima parola in comune
'altrimenti restituisce VERO
WordIntersect = IIf(bRetErr = vbUseDefault, arrSentence1(j), True)
Exit For
End If
Next j
End Function
Torna a Applicazioni Office Windows
Inserimento parziale valore cella in MessageBox Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 6 |
Aggiornare cella con somma quando aggiungo nuova colonna Autore: marcopont |
Forum: Applicazioni Office Windows Risposte: 1 |
Aumenta altezza riga in base valore cella Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 47 |
Importare immagini a seconda del testo in una cella Autore: Paolo67met |
Forum: Applicazioni Office Windows Risposte: 4 |
Inserire valore di una cella in altra cella con testo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 17 |
Visitano il forum: Nessuno e 17 ospiti