Sélectionner et grouper images

Bonjour,

Je n'arrive pas à utiliser la fonction

ActiveSheet.Shapes.Range(Array("Picture 171", "Picture 173")).Select

en remplacant la liste des images par une variable comprenant la liste des images

Mon code me permet de nettoyer la cellule D1 (en réalités sur le fichier officile, ce sont les événements du calendrier outlook) des accents et de la ponctuation et de copier le résultat dans D2

Ensuite je sépare avec SPLIT les mots de la cellule D2 et je vérifie pour chaque mot si une image existe avec ce mot dans le répertoire spécifié
C:\Users\Sylvain Lucie\Documents\images (il existe une image pour chaque prénom)
Si l'image existe je la rajoute à la variable ListeImages en récupérant MonImage.Name

Pour finir j'affiche pour info la variable ListeImages et j'obtiens bien : "Picture 171", "Picture 173"

J'essaie ensuite d'insérer cette variable dans la fonction

ActiveSheet.Shapes.Range(Array("Picture 171", "Picture 173")).Select

comme ceci

ActiveSheet.Shapes.Range(Array(ListeImages)).Select Ou ActiveSheet.Shapes.Range(Array( & ListeImages &)).Select

mais ca bug à ce niveau.

Pourriez vous svp m'aider?

Voici mon code :

Sub Ellipse1_Cliquer()
    Dim Fichier As String: Dim b As Integer: Dim ListeImages As String: Dim test1 As String: Dim i As Integer
    b = 1: ListeImages = "":
    test1 = Range("d1").Value: test1 = MajSansAccent$(test1): test1 = TexteEpure(test1): Range("d2").Value = test1 'nettoie la chaine des accents et ponctuation
    Mots = Split(Range("D2").Text, " ") 'On obtient donc n mots avec  : Mots(1) = "LUCIE" , Mots(2) = "KAREN"... Donc on peux boucler  :
    For i = 0 To UBound(Mots)
            If i < UBound(Mots) Then ' si pas dernier mot
                Fichier = Dir("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg")
                If Fichier <> "" Then 'si le fichier jpg existe
                    Range("G" & b).Select 'insertion de l'image dans la cellule "G"&b
                    Set MonImage = ActiveSheet.Pictures.Insert("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg")
                    If ListeImages <> "" Then 'insertion du nom de l'image dans la liste des images
                        ListeImages = ListeImages & """" & MonImage.Name & """" & ", "
                    Else
                        ListeImages = ListeImages & """" & MonImage.Name & """" & ", "
                    End If
                Else
                    MsgBox "Le fichier jpg de " & Mots(i) & " n'a pas été trouvé"
                End If
            Else 'si dernier mot
                Fichier = Dir("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg")
                If Fichier <> "" Then
                    Range("G" & b).Select
                    Set MonImage = ActiveSheet.Pictures.Insert("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg")
                    If ListeImages <> "" Then
                        ListeImages = ListeImages & """" & MonImage.Name & """"
                    Else
                        ListeImages = ListeImages & MonImage.Name & """"
                    End If
                Else
                    MsgBox "Le fichier jpg de " & Mots(i) & " n'a pas été trouvé"
                End If
            End If
        b = b + 1
    Next i
    MsgBox ListeImages

    'ActiveSheet.Shapes.Range(Array("Picture 171", "Picture 173")).Select
    'Selection.ShapeRange.Group
    ActiveSheet.Shapes.Range(Array(ListeImages)).Select
End Sub
Function MajSansAccent$(ByVal Chaine$)
'Ti
Const VAccent = "àáâãäåéêëèìíîïðòóôõöùúûü", VSsAccent = "aaaaaaeeeeiiiioooooouuuu"
Dim Bcle&
For Bcle = 1 To Len(VAccent)
Chaine = Replace(Chaine, Mid(VAccent, Bcle, 1), Mid(VSsAccent, Bcle, 1))
Next Bcle
MajSansAccent = UCase(Chaine)
End Function

Function TexteEpure(Texte As String) As String
' supprime tous les caractères AUTRES
' que "a à z","A à Z" ou chiffre.
' voir aide sur ASC et table de caractères ASCII.
Dim tempmot As String, TempCar As String
For i = 1 To Len(Texte)
TempCar = Mid(Texte, i, 1)
Select Case Asc(TempCar)
Case 48 To 57 'chiffre
Case 65 To 90 'caractères A à Z
Case 97 To 122 'caractères a à z
Case Else
TempCar = " "
End Select
tempmot = tempmot + TempCar
Next i
TexteEpure = tempmot
End Function

Je voudrais ensuite grouper ses images sélectionnées côte à côte

Je vous remercie beaucoup

Cordialement

Bonjour,

Pb résolu en stockant les images dans un tableau

Sub Ellipse1_Cliquer()
    Dim Fichier As String: Dim test1 As String: Dim i As Integer
    Application.ScreenUpdating = False
    test1 = Range("d1").Value: test1 = MajSansAccent$(test1): test1 = TexteEpure(test1): Range("d2").Value = test1 'nettoie la chaine des accents et ponctuation
    Mots = Split(Range("D2").Text, " ") 'On obtient donc n mots avec  : Mots(1) = "LUCIE" , Mots(2) = "KAREN"... Donc on peux boucler  :
    For i = 0 To UBound(Mots)
            If i <= UBound(Mots) Then ' boucle sur les mots
                Fichier = Dir("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg") 'cherche image dans reprtoire
                If Fichier <> "" Then 'si le fichier jpg existe
                    Range("G1").Select 'insertion de l'image dans la cellule "G"&b
                    Set MonImage = ActiveSheet.Pictures.Insert("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg")
                    limage = MonImage.Width: MonImage.Left = Range("G1").Left + l: l = l + limage 'insertion image cote à cote selon la largeur de l'image précédente
                Else
                    MsgBox "Le fichier jpg de " & Mots(i) & " n'a pas été trouvé"
                End If
            End If
    Next i

    Dim xPicRg As Range: Dim k As Integer: Dim Tableau() As String: Dim xPic As Shape: Dim xRg As Range
    Set xRg = Range("e1:x100") 'selection de la plage de cellules
        For Each xPic In ActiveSheet.Shapes 'recherche les images de la plage
            Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
            If Not Intersect(xRg, xPicRg) Is Nothing Then
                k = k + 1: ReDim Preserve Tableau(1 To k) 'Redéfinit la taille du tableau et intègre le nom de la forme.
                Tableau(k) = xPic.Name 'insére image dans le tableau
            End If
        Next
    If k = 0 Then Exit Sub
    Set Sh = ActiveSheet.Shapes.Range(Tableau).Group 'Regroupe les formes dont le nom se trouve dans le tableau 'Sh.Name = "NomGroupe" 'Renomme le groupe. 'ActiveSheet.Shapes.Range(Array("NomGroupe")).Select
    Sh.Select: Selection.Cut: Range("D9").Select: ActiveSheet.Pictures.Paste.Select: Selection.ShapeRange.Top = Range("D9").Top + 20: Selection.ShapeRange.Left = Range("D9").Left + 20

    Application.ScreenUpdating = True
End Sub

Voila pour ceux que ca peut interesser

Cordialement