Public Sub MENU_ImporterImages()
Dim DirectoryImage, SearchString As String
Dim she, FoundAt, objShell As Object, objFolder As Object, oFolderItem As Object
Dim oRange As Range, aCell As Range, bCell As Range
Dim Chemin As String
Dim reponse As String


 Dim fldr As FileDialog
   reponse = MsgBox("Importer sur toutes les feuilles sélectionnées ", vbYesNo, "Sondage")
     Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = "LIEN"
        If .Show <> -1 Then
            MsgBox "Error"
         Else
            
         Chemin = .SelectedItems(1)
        End If
    End With
    
    Dim Pattern As String ' Ici on sait que l'on demande un Integer
    Pattern = InputBox("Entrez le format de la chaine de la reference : ", "ex : ???????.??", "???????.??")
   
    
    For Each she In ActiveWindow.SelectedSheets
    
    If (she Is ActiveSheet Or reponse = vbYes) Then
    On Error Resume Next
   
    On Error GoTo 0
    If Chemin <> "" Then
  
     
    Set aCell = she.UsedRange.Find(What:=Pattern, LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        'on ajoute l'image
        Dim ficimg As String
        On Error Resume Next
         she.Shapes.AddPicture(Chemin & "\" & Replace(aCell, ".", "-") & ".jpg", False, True, 0, 0, -1, -1).Select
        With Selection.ShapeRange
            .LockAspectRatio = True
            .Top = aCell.Top + 2
            .Left = aCell.Left
            .Width = aCell.Width
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            .Height = aCell.Height - 4
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            
            .Top = aCell.MergeArea.Top + 2
            .Left = aCell.MergeArea.Left
            .Width = aCell.MergeArea.Width
            .Height = aCell.MergeArea.Height - 4
            .Left = aCell.Left + ((aCell.MergeArea.Width - Selection.ShapeRange.Width) / 2)
            
            '.AlternativeText = sargs(0)
        End With
        With Selection
        .Locked = False
        .PrintObject = True
        .Placement = xlMoveAndSize
        .ShapeRange.ZOrder msoSendToBack
        '.Name = pict.Name
        End With
       
        Set bCell = aCell
       Do
            Set aCell = she.UsedRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                 On Error Resume Next
        ficimg = she.Shapes.AddPicture(Chemin & "\" & Replace(aCell, ".", "-") & ".jpg", False, True, 0, 0, -1, -1).Select
        With Selection.ShapeRange
            .LockAspectRatio = True
            .Top = aCell.Top + 2
            .Left = aCell.Left
            .Width = aCell.Width
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            .Height = aCell.Height - 4
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            
            .Top = aCell.MergeArea.Top + 2
            .Left = aCell.MergeArea.Left
            .Width = aCell.MergeArea.Width
            .Height = aCell.MergeArea.Height - 4
            .Left = aCell.Left + ((aCell.MergeArea.Width - Selection.ShapeRange.Width) / 2)
            
            '.AlternativeText = sargs(0)
        End With
        With Selection
        .Locked = False
        .PrintObject = True
        .Placement = xlMoveAndSize
        .ShapeRange.ZOrder msoSendToBack
        '.Name = pict.Name
        End With
            Else
                Exit Do
            End If
        Loop
    End If
    End If
  End If
 Next she
End Sub