Condividi:        

Ricerca "Particolare" da celle [excel2010 & vb]

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Ricerca "Particolare" da celle [excel2010 & vb]

Postdi alex_lougher » 04/09/12 16:46

Salve Ragazzi, Avevo un dubbio e solo a voi posso rivolgermi.
Ho due cartelle di lavoro, "database" e "lavoro" , ora nella cartella lavoro , ho un foglio "foglio1" in cui ho la colonna "A" con dei codici alfanumerici e con simboli.Con la funzione FIND riesco a fare la ricerca del codice della colonna "A" nel mio database.
ora per farvi capire il mio problema vi faccio un esempio:
se il valore da ricercare è bsr152 e il valore che ho nel database è bsr152vlm la ricerca va a buon fine

invece in caso contrario:
se il valore da ricercare è bsr152vlm e il valore che ho nel database è bsr152 la ricerca non va a buon fine.
Io vorrei una qualche funzione o macro che faccia in modo da ricercare la stringa nel database, e nel caso non ci siano corrispondenze esatte, voglio che mi dia in output in una listgrid la lista dei valori trovati nel mio database che più si avvicinano al valore Ricercato.
Mi basta avere una dritta...

Please help me!!
ps. la cartella di lavoro "database" è composta da un unico foglio.
alex_lougher
Utente Junior
 
Post: 22
Iscritto il: 06/07/12 09:25

Sponsor
 

Re: Ricerca "Particolare" da celle [excel2010 & vb]

Postdi Flash30005 » 04/09/12 22:31

Non è così semplice specialmente se dici che il codice è alfanumerico perché quel "bsr.." potrebbe essere anche "Bsr" o bSr" o "bsR" o "BSr" o "BsR" o "bSR" o "BSR" sperando che non sia così (non perché è impossibile ma perché bisognerebbe implementare questa macro
Codice: Seleziona tutto
Sub trova()
Set Ws1 = Worksheets("foglio1")   '<<<<<<<<<<< nome foglio
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Ws1.Range("S2:S10000").ClearContents
Ws1.Columns(20).ClearContents
StrC = [S1]    '<<<<<<<<<<<<<<< valore/stringa da ricercare
LStrC = Len(StrC)
StrCM = UCase(StrC)
Tr = 0
For RR1 = 2 To UR1
    If Ws1.Range("A" & RR1).Value = StrC Then
        Ws1.Range("T1").Value = Ws1.Range("T1").Value + 1
        GoTo saltaRR1
    Else
        If Left(Ws1.Range("A" & RR1).Value, LStrC) = StrC Then
            UR2 = Ws1.Range("S" & Rows.Count).End(xlUp).Row + 1
            Tr = 1
            For RR2 = 2 To UR2
                If Ws1.Range("S" & RR2).Value = Ws1.Range("A" & RR1).Value Then
                    Ws1.Range("T" & RR2).Value = Ws1.Range("T" & RR2).Value + 1
                    Tr = 0
                    GoTo saltaRR1
                End If
                If Tr = 1 Then
                    UR2 = Ws1.Range("S" & Rows.Count).End(xlUp).Row + 1
                    Ws1.Range("S" & UR2).Value = Ws1.Range("A" & RR1).Value
                    Tr = 0
                End If
            Next RR2
        End If
    End If
saltaRR1:
Next RR1
End Sub


Avrai un elenco dei nomi simili nella colonna S e nella T la presenza dei suddetti nomi

Fai attenzione che le colonne S e T sono colonne di servizio pertanto vengono cancellate ogni volta (se sono utilizzate dal tuo database varia i riferimenti nella macro)

ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Ricerca "Particolare" da celle [excel2010 & vb]

Postdi Sasyjoe » 05/09/12 11:43

Se può essere utile fra vari Topic "vecchi" che leggevo ho trovato questo che potrebbe essere utile:

viewtopic.php?f=26&t=87303&hilit=rubrica

Ciao
Sasyjoe
Utente Senior
 
Post: 404
Iscritto il: 04/05/12 13:27

Re: Ricerca "Particolare" da celle [excel2010 & vb]

Postdi Anthony47 » 06/09/12 14:53

Alex non ha risposto alla macro pubblicata da Flash o con quanto linkato da Sasyjoe, quindi non so se il problema puo' considerarsi risolto.
Comunque pubblico l' adattamento della conversione in vba di un lavoro fatto in gwbasic "qualche anno fa", che serviva a ritrovare le similitudini in un elenco di record.
Il codice:
Codice: Seleziona tutto
Sub fuzzy(ByVal myStr As String, Optional ByVal MinPol As Long = 2)
'(c) by Anthony47
'myStr e' la stringa che sara' controllata nell' elenco
'MinPol e' la minima lunghezza del polinomio che sara' usata per i confronti; 2 di default
'Richiamare quindi con Call fuzzy(myStr ,[MinPol])
'
Dim CheckArea As String, Cell As Range, myString As String, mySString As String, CellaV As String
Dim I As Long, J As Long, myScore As Long, MaxJ As Long, LastR As Long
Dim VRis(), SimilArea As String, SimilNum As Long
'
myString = UCase(Replace(myStr, " ", ""))
If Len(myString) < MinPol Then MinPol = Len(myString)
'Qualche informazione sul problema:
CheckArea = "A2"    '<<< Inizio dell' elenco su cui cercare
SimilArea = "C2"    '<<< Inizio dell' area su cui si scriveranno i dati simili
SimilNum = 7        '<<< Numero di similitudini che saranno riportate

'
LastR = Cells(Rows.Count, Range(CheckArea).Range("A1").Column).End(xlUp).Row
ReDim VRis(1 To LastR)

For KK = 1 To LastR + 1 - Range(CheckArea).Range("A1").Row
myScore = 0: CellaV = UCase(Replace(Range(CheckArea).Range("A1").Offset(KK - 1, 0).Value, " ", ""))

    For I = 1 To Len(myString)
        If Len(CellaV) < (Len(myString) - I + 1) Then MaxJ = Len(CellaV) Else MaxJ = Len(myString) - I + 1
        For J = MaxJ To MinPol Step -1
            mySString = Mid(myString, I, J)
            If Len(CellaV) <> Len(Replace(CellaV, mySString, "")) Then
                myScore = myScore + (J * J)
                If mySString = CellaV Then
                    myScore = myScore + (J * J * J * J)
                End If
                Exit For
            End If
        Next J
    Next I
    VRis(Range(CheckArea).Range("A1").Offset(KK - 1, 0).Row) = Round(myScore + 0.1 / KK, 6) - Abs((Len(CellaV) - Len(myString)) / (Len(myString) + 1))
'SCOMMENTARE la prossima per avere lo score accanto alla lista
'    Range(CheckArea).Range("A1").Offset(KK - 1, 1) = myScore + 0.1 / KK
Next KK
'Output Risultati
Range(SimilArea).Resize(SimilNum, 2).ClearContents
For I = 1 To SimilNum
    mypos = Application.Match(Application.WorksheetFunction.Large(VRis(), I), VRis(), 0)
    If Not IsError(mypos) And Application.WorksheetFunction.Large(VRis(), I) > 0.1 Then
        Range(SimilArea).Offset(I - 1, 0) = Cells(mypos, Range(CheckArea).Column)
        Range(SimilArea).Offset(I - 1, 1) = Round(Application.WorksheetFunction.Large(VRis(), I), 0)
    End If
Next I
'Crea un named range
Range(SimilArea).Resize(SimilNum).Name = "Simili"
End Sub

Si richiama da una' altra macro, ad esempio io ho usato
Codice: Seleziona tutto
Sub testfuzzy()
Call fuzzy(Range("B1").Value, Range("C1").Value)
End Sub

L' ambiente di test con relativi risultati e' questo:

Immagine

Uploaded with ImageShack.us
In B1 la stringa da ricercare, in C1 la lunghezza minima dei polinomi di confronto; in colonna A le voci in cui ricercare.
In C2 e sottostanti le similitudini ritrovate; in D2 e sottostanti il coefficiente di similitudine (da confrontare con gli altri punteggi nella lista).
La macro inoltre crea un Intervallo con nome Simili che puo' essere usata come riferimento per l' elenco di una cella con convalida, o OrigineDati per una Combobox o una ListBox e simili.

Se usate il codice vi invito a non modificare le prime 4 righe della Sub fuzzy cosi' come le ho riportate.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Ricerca "Particolare" da celle [excel2010 & vb]

Postdi alex_lougher » 06/09/12 16:33

Grazie a tutti per l'interessamento e per le risposte, oggi inizio ad applicare qste macro..appena ho qlk novità vi aggiorno!!
alex_lougher
Utente Junior
 
Post: 22
Iscritto il: 06/07/12 09:25


Torna a Applicazioni Office Windows


Topic correlati a "Ricerca "Particolare" da celle [excel2010 & vb]":


Chi c’è in linea

Visitano il forum: Nessuno e 74 ospiti