Copier coller format image

Bonjour à tous,

Voila, j'ai un petit problème (minuscule), mais qui me prend un temps fou.

Dans une feuille Excel, je dois importer 3-4 tableaux de tailles différentes. Pour cela, je crée un tableau par ongle puis, je fais un copier/Coller format image dans l'onglet principal, en dessous du tableau précédent.

Le problème viens du fait que VBA renomme automatiquement les images. Par exemple, si je test 5 fois la macro le programme va attribuer le nom image1 à la sélection (tableau) pour le premier test et image5 pour le 5iem test.

Le hic c'est qu'en fin de programme lorsque je veux aligner les Tableaux ça bloque.

J'ai essayé les variables, en vain (sacré débutant!).

Merci par avance.

Cordialement,

Stan

Bonjour,

Il serait judicieux de fournir ton code, et éventuellement ton fichier !

Si tu veux que tes images soient nommées de façon stable, c'est à toi de les nommer !

Cordialement.

Bonjour,

Désolé mon entreprise ne me permet pas de joindre des fichiers.

cependant, voici le code utilisé:

Sub import_b1()

    Sheets("Tab1").Select
    Range("B5:T10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("ABR").Select
    Range("B24").Select
    ActiveSheet.Pictures.Paste.Select
    Selection.ShapeRange.Width = 873.0708661417

    Sheets("Tab2").Select
    Columns("A:T").EntireColumn.AutoFit 
    Application.Goto Reference:="DimTab2" 
    Selection.Copy

    Sheets("ABR").Select
    Range("B41").Select
    ActiveSheet.Pictures.Paste.Select
    Selection.ShapeRange.Width = 873.0708661417
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 232.4409448819

Sheets("Tab3").Select
    Application.Goto Reference:="DimTab3"
    Application.CutCopyMode = False
    Selection.Copy

    Sheets("ABR").Select
    Range("B62").Select
    ActiveSheet.Pictures.Paste.Select

    ActiveSheet.Shapes.Range(Array("Picture 1", "Picture 2", "Picture 3")). _
        Select ' C'est ici que ça bloque ! lorsque l'on exécute plusieurs fois la macro les numéros s’incrémentent 
    Selection.ShapeRange.Align msoAlignCenters, msoFalse

End sub

Merci par avance,

Stan

Bonjour,

J'écrirai déjà ainsi :

Sub import_b1()
    Dim T!, L!, W!, H!
    With Sheets("ABR")
        L = .Range("B24").Left: T = .Range("B24").Top
        W = 873.0708661417: H = 232.4409448819
        Sheets("Tab1").Range("B5:T10").Copy
        With .Pictures.Paste
            .Name = "img_1"
            .Top = T: .Left = L: .Width = W
        End With
        T = .Range("B41").Top
        Sheets("Tab2").Columns("A:T").AutoFit
        [DimTab2].Copy
        With .Pictures.Paste
            .Name = "img_2"
            .Top = T: .Left = L
            .LockAspectRatio = msoFalse: .Width = W: .Height = H
        End With
        T = .Range("B62").Top
        [DimTab3].Copy
        With .Pictures.Paste
            .Name = "img_3"
            .Top = T: .Left = L
        End With
        .Shapes.Range(Array("img_1", "img_2", "img_3")).Align msoAlignCenters, msoFalse
    End With
End Sub

Sans y voir de plus près, cela reste quelque peu bricolé encore, mais on aura au moins supprimé les Select inutile !

Bonjour MFerrand,

J'ai essayé le code que vous m'avez fourni et j'ai une erreur au niveau du .LockAspectRatio = msoFalse

Hormis cela, ça semble fonctionner parfaitement.

Merci par avance.

Stan

Bonjour,

j'ai une erreur au niveau du .LockAspectRatio = msoFalse

Tu le supprime, ça fonctionnera sans...

Cordialement.