VBA excel - Ricerca nome

[macio66]

Codice: Seleziona tutto

Sub RicercaNome()
'dichiarazione delle variabili’:
Dim Trova As Range, Intervallodiricerca As Range
Dim Valore_Ricerca As String, IndirizzoTrovato As String
Dim e As Integer, I As Integer
Dim ur As Integer
Dim Ur1 As Long
'
ur = sh14.Range("A" & (Rows.Count)).End(xlUp).Row
Ur1 = sh2.Range("C" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

'assegnazione dei valori alle variabili:
For e = 3 To Ur1
Valore_Cercato = sh2.Cells(e, "C").Value
    'nella prima pagina del foglio attivo
Set Intervallodiricerca = sh14.Columns(1)
'*******************************

'metodo find, qui si cerca il valore esatto (LookAt:=xlWhole)
Set Trova = Intervallodiricerca.Cells.Find(What:=Valore_Cercato, LookAt:=xlWhole)

'trattamento dell’errore possibile: se non si trova nulla
If Trova Is Nothing Then
    'qui, cosa fare nel caso in cui il valore non è trovato
    ur = sh14.Range("A" & (Rows.Count)).End(xlUp).Row + 1
    sh14.Cells(ur, "A").Value = Valore_Cercato
End If
'pulizia delle variabili
Set Intervallodiricerca = Nothing
Set Trova = Nothing
Next e
'
Application.ScreenUpdating = True
'
Ultima_consegna
'
End Sub

Sub Ultima_consegna()
'
Dim e As Integer
Dim Ur1 As Long
Dim Trova As Range, Intervallodiricerca As Range
Dim nome As String
'
Ur1 = sh2.Range("C" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

nome = sh2.Cells(Ur1, "c").Value             '<<< Il nome da sondare

sh2.Activate

RigaMax = Evaluate("max(if((c2:c10000&""""=""" & nome & """)and (d2:d10000&""""=""" & nome & """),row(a2:a10000),""""))")

If RigaMax = "0" Then Exit Sub

If sh2.Range("E" & RigaMax).Value = "1" Then
    DataMax = Evaluate("max(if((c2:c10000&""""=""" & nome & """),a2:a10000,""""))")

Else
    DataMax = Evaluate("max(if((c2:c10000&""""=""" & nome & """),p2:p10000,""""))")
End If
'
Set Intervallodiricerca = sh14.Columns(1)
'*******************************

'metodo find, qui si cerca il valore esatto (LookAt:=xlWhole)
Set Trova = Intervallodiricerca.Cells.Find(What:=nome, LookAt:=xlWhole)
    e = Trova.Row
   
If DataMax = "0" Then
    sh14.Cells(e, "B") = "Non ci sono consegne"
Else
    sh14.Cells(e, "B") = DataMax
End If
'
Set Intervallodiricerca = Nothing
Set Trova = Nothing
'
End Sub

Buongiorno
Uso il codice ( Sub RicercaNome() ) per cercare se il nominativo è presente, altrimenti lo aggiungo, e il codice ( Sub Ultima_consegna() ) per cercare l'ultima consegna fatta.
Andava tutto bene fino a quando, con lo stesso cognome, mi ritrovo piu nominativi.
Adesso per il Valore_Cercato non posso piu fare la ricerca solo sullacolonna "C", ma dovrei aggiungere anche la colonna "D", che corrisponde al nominativo.
Di conseguenza non ho idea di come posso modificare le stringhe per poter fare la ricerca sul cognome e nome :

[/code]Valore_Cercato = sh2.Cells(e, "C").Value

Set Intervallodiricerca = sh14.Columns(1)

Set Trova = Intervallodiricerca.Cells.Find(What:=Valore_Cercato, LookAt:=xlWhole)[/code]

La stessa cosa per trovare la data dell'ultima consegna relativa al nome cercato:

Codice: Seleziona tutto

nome = sh2.Cells(Ur1, "c").Value             '<<< Il nome da sondare

sh2.Activate

RigaMax = Evaluate("max(if((c2:c10000&""""=""" & nome & """)and (d2:d10000&""""=""" & nome & """),row(a2:a10000),""""))")

If RigaMax = "0" Then Exit Sub

If sh2.Range("E" & RigaMax).Value = "1" Then
    DataMax = Evaluate("max(if((c2:c10000&""""=""" & nome & """),a2:a10000,""""))")

Else
    DataMax = Evaluate("max(if((c2:c10000&""""=""" & nome & """),p2:p10000,""""))")
End If

Sperando di essermi spiegato, qualcuno ha qualche dritta da darmi?

[Anthony47]

Ma non hai una colonna che per definizione deve essere univoca, tipo il codice fiscale o la partita Iva? Perche' prima o poi ti troverai con Rossi Mario di Via Roma 33 e Rossi Mario di piazza Mazzini 11, e quando te ne accorgerai avrai gia' fatto qualche casino...

Comunque per essere piu' propositivi sarebbe utile avere un file dimostrativo, con dati versosimili, su cui lavorare.

Ciao

[macio66]

Ciao Anthony
Purtroppo non ho una definizione univoca da usare.
Sto cercando di creare un db per una associazione di volontariato che distribuisce generi alimentari,e non facendone parte, sto cercando di tirare fuori qualcosa che li possa aiutare (in più non sono così bravo con il VBA).
Infatti è capitato proprio quello (un pò di casini!!!!!), non sapendo avevo usato il cognome come riferimento per la ricerca.
Provo a svuotare il file dai dati personali per mandarlo.

[macio66]

Buongiorno
A forza di sbatterci la testa, dovrei esserne venuto a capo. (ovviamente mi farebbe piacere avere un vostro giudizio)
Allego le due macro modificate (potrebbero venire utili a qualcuno poco esperto come me):

1) Per cercare il nominativo avendo due variabili (Cognome & Nome), e se non è presente lo si accoda:

Codice: Seleziona tutto

Sub RicercaNome()

'dichiarazione delle variabili:
Dim e As Integer
Dim ur14, Ur2, lng14, firstAddress As Long
Dim cognome, nome As String
Dim VMax As Variant

ur14 = sh14.Range("A" & (Rows.Count)).End(xlUp).Row
Ur2 = sh2.Range("C" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For e = 3 To Ur2
    'assegnazione dei valori da cercare:
    cognome = sh2.Cells(e, 3)
    nome = sh2.Cells(e, 4)
    With sh14
        For lng14 = 2 To ur14
            If CStr(.Cells(lng14, 1).Value) = cognome And CStr(.Cells(lng14, 2).Value) = nome Then
                presente = "si"
                Exit For
            Else
                presente = "no"
            End If
        Next
    End With
    If presente = "no" Then
        firstAddress = sh14.[A1].End(xlDown).Row + 1
        sh14.Cells(firstAddress, 1).Value = cognome
        sh14.Cells(firstAddress, 2).Value = nome
    End If
Next e

Application.ScreenUpdating = True

Ultima_consegna

End Sub

2) Per la ricerca dell'ultima data di consegna relativa al nome cercato:

Codice: Seleziona tutto

Sub Ultima_consegna()

'dichiarazione delle variabili:
Dim Ur2, ur14, lng2, lng14 As Long
Dim cognome, nome As String
Dim VMax As Variant
'
Ur2 = sh2.Range("C" & Rows.Count).End(xlUp).Row
ur14 = sh14.Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

cognome = sh2.Cells(Ur2, "c").Value          '<<< Il cognome da sondare
nome = sh2.Cells(Ur2, "d").Value             '<<< Il nome da sondare

sh2.Activate

    With sh2
        VMax = 0
        For lng2 = 2 To Ur2
            If CStr(.Cells(lng2, 3).Value) = cognome And CStr(.Cells(lng2, 4).Value) = nome Then
                If .Cells(lng2, 1) > VMax Then VMax = .Cells(lng2, 1)
                    RigaMax = lng2
            End If
        Next
        DataMax = VMax
    End With

If sh2.Range("E" & RigaMax).Value = "NO" Or sh2.Range("E" & RigaMax).Value = "no" Then
    DataMax = sh2.Range("R" & RigaMax).Value
End If

If DataMax = vbNullString Then
    With sh14
        For lng14 = 2 To ur14
            If CStr(.Cells(lng14, 1).Value) = cognome And CStr(.Cells(lng14, 2).Value) = nome Then
                .Cells(lng14, "C") = "Non ci sono consegne"
            End If
        Next
    End With
Else
    With sh14
        For lng14 = 2 To ur14
            If CStr(.Cells(lng14, 1).Value) = cognome And CStr(.Cells(lng14, 2).Value) = nome Then
                    .Cells(lng14, "C") = CDate(DataMax)
                    .Cells(lng14, "C").NumberFormat = "[$-it-IT]d-mmm-yy;@"
            End If
        Next
    End With
End If

End Sub

[Anthony47]

Bravo (e se funziona e' perfetta così)

Ti do uno spunto per una possibile semplificazione...
Potresti nella tua anagrafica aggiungere una colonna che crea, per ogni nominativo, una chiave crittografata che includa quanti campi vuoi (es nome /cognome /data di nascita)
Per crearla puoi usare questa funzione:

Codice: Seleziona tutto

Function StringToMD5Hex(ByVal s As String) As String
Dim enc As Object
Dim bytes() As Byte
Dim pos As Long
Dim outstr As String
'
Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
bytes = StrConv(s, vbFromUnicode)
bytes = enc.ComputeHash_2(bytes)
For pos = LBound(bytes) To UBound(bytes)
   outstr = outstr & LCase(Right("0" & Hex(bytes(pos)), 2))
Next pos
StringToMD5Hex = outstr
Set enc = Nothing
End Function


(l'ho presa non so da quale sito Microsoft)

Per creare questa chiave unica, supponendo che hai Nome /Cognome /data di nascita in A2, B2 e C2 metterai in H2 (o nella colonna dove preferisci) la formula

Codice: Seleziona tutto

=StringToMD5Hex(A2&B2&C2)

Userai poi questa colonna per cercare i nominativi, previa la generazione della chiave usando la stessa funzione.

Ad esempio, se l'anagrafica e' nel foglio "Anagrafe" e la chiave univoca e' in colonna H, puoi cercare se esiste il nominativo con:

Codice: Seleziona tutto

Sub CheckNome()
Dim bDate As Date
Dim myName As String, myFName As String, myMatch
'
myName = "Joe"                      'il Nome
myFName = "Gambadilegno"            'il Cognome
bDate = DateSerial(2020, 1, 1)      'data di nascita
'
myk = StringToMD5Hex(UCase(myName & myFName & CLng(bDate)))         'la chiave univoca
myMatch = Application.Match(myk, Sheets("Anagrafe").Range("H1:H10000"), False)
If IsError(myMatch) Then
    'Non esiste in anagrafica, aggiungi
    With Sheets("Anagrafe")
        mynext = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(mynext, 1) = myName
        .Cells(mynext, 2) = myFName
        .Cells(mynext, 3) = bDate
        'altri dati in anagrafe
        .Cells(mynext, 8) = myk
    End With
Else
    'il nominativo esiste gia'; myMatch indica la riga...
    '
    'le tue istruzioni
    '
End If
End Sub

Vedi se ti puo' tornare utile...

[macio66]

Ciao Anthony
Grazie per il tuo suggerimento, sicuramente lo proverò (per migliorare bisogna sempre sperimentare cose nuove).

Buona Pasquetta a tutti.