macro di ricerca testo parziale

Question

Ciao, 

ho l'esigenza di trovare in un elenco di circa 500 voci disposti in colonna A uno o più nomi , e fin qui ho trovato ed adattato la macro sotto riportata . Il problema per cui chiedo aiuto è di modificarla  in modo che  trovi  il testo richiesto  anche se scritto in forma parziale.

Faccio un esempio,  devo cercare "olio" ma nel mio elenco posso avere: 

Olio di cocco
Olio di colza
Olio di fegato di merluzzo
Olio di germe di grano
Olio di girasole
Olio di mais

con questa macro  se non metto l'esatta denominazione , maiuscole comprese  non trova la corrispondenza. la macro dovrebbe pormi la scelta, oltre a ciò sarebbe utile che non distingua tra maiuscole e minuscole. 

Forse chiedo troppo, ma no  saprei proprio come fare. Grazie a chi vorrà dedicarmi un poco del suo tempo.

Option Explicit

Sub CercaEcopia()

    Dim cfRiga As Long

    Dim fgRiga As Long

    Dim Col As Long

    Dim fgCol As Long

    Dim shCF As Worksheet 'foglio in cui copiare previa scansione

    Dim shFg1 As Worksheet ' foglio da cui copiare

    Set shCF = Worksheets("Foglio1")

    Set shFg1 = Worksheets("Tab_Alimenti")

    shCF.Range("b2:z100").Clear

    cfRiga = 2

    Do While shCF.Cells(cfRiga, 1) <> "" 'colonna del fo Cf base di ricerca

        fgRiga = fnCerca(shFg1, shCF.Cells(cfRiga, 1).Text)

        If fgRiga > 0 Then

            'copia celle V÷AC

            fgCol = 2

            For Col = 2 To 25

                shCF.Cells(cfRiga, Col) = shFg1.Cells(fgRiga, fgCol)

                fgCol = fgCol + 1

            Next Col

        End If

        cfRiga = cfRiga + 1

    Loop

       Range("B2:Z100").Select

    With Selection

        .HorizontalAlignment = xlRight

        .VerticalAlignment = xlBottom

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .MergeCells = False

    End With

    shCF.Range("a1").Select

End Sub

Answer 1

Ciao Giancarlo,

la mia esigenza è schematicamente qui riassunta : 

1)dato un elenco di voci generiche in Fo1 p.es : olio, carciofi, pollo 

2. trovare per ciascuna voce la corrispondenza esatta su  fo Tab_Alimenti, per es. : olio di oliva - carciofi microonde -  pollo,petto,cotto
3. selezionare quella di mio interesse,

4 Copiare sia la denominazione che l'intera riga su foglio1 sovrascrivendo la voce generica, oppure sotto e annullando alla fine le voci generiche .

Un po troppo complicato per le mie forze, ma le due macro nell'esempio, sapientemente assemblate, dovrebbero riuscire  a risolvere il tutto. 

Prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrDatabase As Variant, arrReport As Variant

    Dim Res As Variant

    Dim sStr As String, sChiave_Ricerca As String

    Dim sMsg As String, sTitle As String

    Dim iButtons As VbMsgBoxStyle

    Dim iRow As Long, jRow As Long

    Dim i As Long, j As Long, k As Long

    Dim iCtr As Long

    Dim UB As Long, UB2 As Long

    Const sFoglio_Report As String = "Foglio1"                    '<<=== Modifica

    Const sFoglio_Database As String = "Tab_Alimenti"       '<<=== Modifica

    Const iPrimaRiga_Database As Long = 5                          '<<=== Modifica

    Const sUltimaColonna_Database As String = "Z"             '<<=== Modifica

    Const iPrimaRiga_Report As Long = 6                              '<<=== Modifica

    sChiave_Ricerca = InputBox("Cosa vuoi cercare ?")

    If sChiave_Ricerca = vbNullString Then

        sMsg = "L'Elaborazione termina senza effettuare la ricerca"

        sTitle = "OPERAZIONE CANCELLATA"

        iButtons = vbCritical

         GoTo XIT

    End If

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglio_Database)

        Set destSH = .Sheets(sFoglio_Report)

    End With

    With srcSH

        iRow = LastRow(srcSH, .Columns("A:A"))

        Set srcRng = .Range("A" & iPrimaRiga_Database & ":" _

                            & sUltimaColonna_Database & iRow)

        arrDatabase = srcRng.Value

        UB = UBound(arrDatabase)

        UB2 = UBound(arrDatabase, 2)

        ReDim arrReport(1 To UB, 1 To UB2)

    End With

    With destSH

        jRow = LastRow(destSH, .Columns("A:A"), iPrimaRiga_Report)

        Set destRng = .Range("A" & iPrimaRiga_Report & ":A" & jRow).EntireRow

        destRng.ClearContents

    End With

    For i = 1 To UB

        sStr = arrDatabase(i, 1)

        Res = InStr(1, sStr, sChiave_Ricerca, vbTextCompare)

        If Res Then

            iCtr = iCtr + 1

            For j = 1 To UB2

                arrReport(iCtr, j) = arrDatabase(i, j)

            Next j

        End If

    Next i

    If iCtr Then

        On Error GoTo XIT

        Application.ScreenUpdating = False

        destRng.Resize(iCtr, UB2).Value = arrReport

        sMsg = iCtr & " risultati trovati per la query"

        sTitle = "Report"

        iButtons = vbInformation

    Else

        sMsg = "La chiave ricerca " & sChiave_Ricerca _

               & " non è stata trovata!"

        sTitle = "Nessuna corrispondenza trovata per la query"

        iButtons = vbCritical

    End If

XIT:

    Application.ScreenUpdating = True

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=iButtons, _

         Title:=sTitle)

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

'<<=========

===

Regards,

Norman

Answer 2

Ciao  Norman, 

la mia esigenza è schematicamente qui riassunta :

1)dato un elenco di voci generiche in Fo1 p.es : olio, carciofi, pollo 

2. trovare per ciascuna voce la corrispondenza esatta su  fo Tab_Alimenti, per es. : olio di oliva - carciofi microonde -  pollo,petto,cotto
3. selezionare quella di mio interesse,

4 Copiare sia la denominazione che l'intera riga su foglio1 sovrascrivendo la voce generica, oppure sotto e annullando alla fine le voci generiche .

Un po troppo complicato per le mie forze, ma le due macro nell'esempio, sapientemente assemblate, dovrebbero riuscire  a risolvere il tutto.

Answer 3

Ciao Giancarlo,

Sorry, mi sono dimenticato della funzione di ricerca.  Provvedo sotto.

Come avrai già intuito ho un elenco variabile a mia discrezione di  alimenti e altro che scrivo nel  foglio1, da qui  interrogo una tabella "Tab_alimenti" dove in colonna 1 ho la denominazione e a lato, stessa riga la composizione. Ebbene questa composizione deve essere riportata nel foglio.1 

questo è quanto fa la macro sopra riportata, il problema è che nella descrittiva della  tab_alimenti ho voci simili  all'interno delle quali vorrei fare la selezione e quindi importare. 

Function fnCerca(shFg1 As Worksheet, txt As String) As Long

    Dim riga As Long

    riga = 5

    Do While shFg1.Cells(riga, 1) <> ""

        If shFg1.Cells(riga, 1) = txt Then

            fnCerca = riga

            Exit Do

        End If

        riga = riga + 1

    Loop

End Function

allego link dove puoi trovare il file fin qui costruito.

http://www.filedropper.com/mioesempio1norman

Se ho capito bene la tua esigenza, tu vuoi precisare una chiave di ricerca, ad esempio la singola parola Oli o o Carciofi e poi restituire tutte le righe corrispondenti della database. 

Se questa interpretazione è valida, penso che sarà necessario sostituire il tuo codice. Come prevedrei il codice, sarebbe possibile sfruttare una casella di input per stipulare una o più espressioni chiave. In questo modo, immettendo la parola chiave Carciofi, le quattro righe 135:138 della database sarebbero copiate sul Foglio1

===

Regards,

Norman

Answer 4

Sorry, mi sono dimenticato della funzione di ricerca.  Provvedo sotto.

Come avrai già intuito ho un elenco variabile a mia discrezione di  alimenti e altro che scrivo nel  foglio1, da qui  interrogo una tabella "Tab_alimenti" dove in colonna 1 ho la denominazione e a lato, stessa riga la composizione. Ebbene questa composizione deve essere riportata nel foglio.1 

questo è quanto fa la macro sopra riportata, il problema è che nella descrittiva della  tab_alimenti ho voci simili  all'interno delle quali vorrei fare la selezione e quindi importare. 

Function fnCerca(shFg1 As Worksheet, txt As String) As Long

    Dim riga As Long

    riga = 5

    Do While shFg1.Cells(riga, 1) <> ""

        If shFg1.Cells(riga, 1) = txt Then

            fnCerca = riga

            Exit Do

        End If

        riga = riga + 1

    Loop

End Function

allego link dove puoi trovare il file fin qui costruito.

http://www.filedropper.com/mioesempio1norman

grazie.

Answer 5

Ciao Giancarlo,

ho l'esigenza di trovare in un elenco di circa 500 voci disposti in colonna A uno o più nomi , e fin qui ho trovato ed adattato la macro sotto riportata . Il problema per cui chiedo aiuto è di modificarla  in modo che  trovi  il testo richiesto  anche se scritto in forma parziale.

Faccio un esempio,  devo cercare "olio" ma nel mio elenco posso avere: 

Olio di cocco
Olio di colza
Olio di fegato di merluzzo
Olio di germe di grano
Olio di girasole
Olio di mais

con questa macro  se non metto l'esatta denominazione , maiuscole comprese  non trova la corrispondenza. la macro dovrebbe pormi la scelta, oltre a ciò sarebbe utile che non distingua tra maiuscole e minuscole. 

Forse chiedo troppo, ma no  saprei proprio come fare. Grazie a chi vorrà dedicarmi un poco del suo tempo.

Option Explicit

Sub CercaEcopia()

    Dim cfRiga As Long

    Dim fgRiga As Long

    Dim Col As Long

    Dim fgCol As Long

    Dim shCF As Worksheet 'foglio in cui copiare previa scansione

    Dim shFg1 As Worksheet ' foglio da cui copiare

    Set shCF = Worksheets("Foglio1")

    Set shFg1 = Worksheets("Tab_Alimenti")

    shCF.Range("b2:z100").Clear

    cfRiga = 2

    Do While shCF.Cells(cfRiga, 1) <> "" 'colonna del fo Cf base di ricerca

        fgRiga = fnCerca(shFg1, shCF.Cells(cfRiga, 1).Text)

        If fgRiga > 0 Then

            'copia celle V÷AC

            fgCol = 2

            For Col = 2 To 25

                shCF.Cells(cfRiga, Col) = shFg1.Cells(fgRiga, fgCol)

                fgCol = fgCol + 1

            Next Col

        End If

        cfRiga = cfRiga + 1

    Loop

       Range("B2:Z100").Select

    With Selection

        .HorizontalAlignment = xlRight

        .VerticalAlignment = xlBottom

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .MergeCells = False

    End With

    shCF.Range("a1").Select

End Sub

Purtroppo non hai pubblicato il codice della tua funzione fnCerca.

Detto questo, penso che sia necessario fornire maggiori informazioni sulla composizione del tuo elenco. Se la parola chiave di ricerca è sempre Olio, o almeno la prima parola in ogni cella di interesse, dovrebbe essere possibile adattare il codice di conseguenza.

===

Regards,

Norman