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

Grazie Norman, perfetto!

Una  ultimissima info : se volessi condividere il file finale, è possibile ? se si, come devo fare ?

Ancora grazie e complimenti  per la tua disponibilità e competenza.

Answer 2

Ciao Giancarlo,

Grazie Norman, la macro funziona perfettamente nel senso che trasferisce su foglio1 l'intera selezione che deriva dalla ricerca su tab_alimenti.  Immaginando che questo foglio1 sia sempre vuoto, è possibile modificare la macro  in modo che scriva sotto, senza cancellare nulla  ? 

Ancora grazie .

Prova le seguente modifica del mio codice:

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

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

    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

        destSH.Cells(jRow + 1, "A").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 3

Grazie Norman, la macro funziona perfettamente nel senso che trasferisce su foglio1 l'intera selezione che deriva dalla ricerca su tab_alimenti.  Immaginando che questo foglio1 sia sempre vuoto, è possibile modificare la macro  in modo che scriva sotto, senza cancellare nulla  ? 

Ancora grazie .