Comment afficher tous les résultats qui contients la valeur d'une celllule

Option Explicit
Option Compare Text

Public Sub MatchListWithPics()
'look for a string to search (list of references)
'and search all files in a folder and look inside names

Dim SuppRefLst As Range
Set SuppRefLst = Application.InputBox("Please select the cells with Supplier References", Type:=8)

maxFiles = 5 'upload up to 5 files to the website
'select folder with pics to look into names
searchIn = ListFilesinFolder

'add reference and result
ReDim finalResult(1 To SuppRefLst.Rows.Count, 0 To maxFiles) As String '0 is for initial reference

For I = 1 To SuppRefLst.Rows.Count

StrToSearch = SuppRefLst(I, 1).Value

ReDim Res(1 To maxFiles) As Variant
Res = FindText_IgnoreCase(StrToSearch, searchIn, maxFiles)

For j = 1 To maxFiles
If j = 1 Then finalResult(I, 0) = StrToSearch
finalResult(I, j) = Res(j)
Next j
Next I


'to write Results inside new book
Workbooks.Add
Range("A1").Resize(SuppRefLst.Rows.Count, maxFiles + 1) = finalResult '+1 for supplier reference
Cells.Columns.AutoFit

Erase finalResult
End Sub
Public Function ListFilesinFolder()
'ONLY PICTURES

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim I As Integer

fLocation = SelectFolder("please select a folder!")

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(fLocation)


ReDim Result(1 To oFolder.Files.Count, 1 To 1) As String

For Each oFile In oFolder.Files
If LCase(Split(oFile.Name, ".")(1)) = "jpg" Or LCase(Split(oFile.Name, ".")(1)) = "jpeg" _
Or LCase(Split(oFile.Name, ".")(1)) = "bmp" Or LCase(Split(oFile.Name, ".")(1)) = "png" _
Or LCase(Split(oFile.Name, ".")(1)) = "ico" Or LCase(Split(oFile.Name, ".")(1)) = "gif" Then

Result(I + 1, 1) = oFile.Name
I = I + 1
End If
Next oFile

ListFilesinFolder = Result

Erase Result
End Function

Public Function FindText_IgnoreCase(ByVal searchWhat As String, ByVal SearchArray As Variant, ByVal maxF As Integer) As Variant
ReDim Result(1 To maxF) As Variant
Dim cpt As Integer
cpt = 1

For I = 1 To UBound(SearchArray, 1)
'replace special characters in both string for more accurate search
sourceStr = ReplaceSpecialCharacters(SearchArray(I, 1))
whatStr = ReplaceSpecialCharacters(searchWhat)
whatStrShort = ReplaceSpecialCharacters(searchWhat, 12)

If InStr(1, sourceStr, _
whatStr, vbTextCompare) _
> 0 Then 'no case Sensitivity

'add to result if < maxFiles
If cpt <= maxF Then
Result(cpt) = SearchArray(I, 1)
cpt = cpt + 1
End If
ElseIf sourceStr Like "*" & whatStrShort & "*" = True _
And SearchArray(I, 1) <> "" Then

'add to result if < maxFiles
If cpt <= maxF Then
Result(cpt) = SearchArray(I, 1)
cpt = cpt + 1
End If

End If
Next I

FindText_IgnoreCase = Result
Erase Result
End Function

Public Function ReplaceSpecialCharacters(ByVal myString As String, Optional ByVal lengthOutput As Integer = 0)
Dim SpecialCharacters As String
SpecialCharacters = "-,_,#" 'modify as needed

Dim newString As String
Dim char As Variant

'pass the value
newString = myString
For Each char In Split(SpecialCharacters, ",")
'change characters one by one, replace it by space
newString = Replace(newString, char, " ")
Next


If lengthOutput > 0 Then
ReplaceSpecialCharacters = Left(newString, lengthOutput)
Else
ReplaceSpecialCharacters = newString
End If

End Function