Macro copier/coller sous forme d'image

Question

Bonjour, 

j'ai actuellement un code qui sélectionne une plage de donnée de ma feuil1 pour les recoller sous forme d'une image dans la feuil3. Je n'arrive pas à faire simple pour que les images se collent les une en dessus des autres dans la feuil3 (j'ai essayé de contourner un peu le problème sans grand résultats).

Voilà mon code : 

Sub Macro1()

    Sheets("Feuil3").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "a"
    Sheets("Feuil1").Select
    Range("C3:L23").Select
    Selection.Copy
    Sheets("Feuil3").Select
    Range("A65536").End(xlUp).Offset(0, 1).Select
    ActiveSheet.Pictures.Paste.Select
    ActiveSheet.Shapes.Range(Array("Picture 3")).Select
    Sheets("Feuil1").Select
    
    
End Sub

Merci de votre aide 
KG

pijaku · Answer

Bonjour,

Pour cela, il faut boucler sur toutes les images contenues dans la feuille Feuil3, comparer leurs propriétés .top (hauteur dans la feuille), et, l'image qui a le top le plus élevé est la dernière dans ta feuille. Par conséquent, ta nouvelle image devra être placée à :
.Left = 0
.Top = .TopDernImg + .HeightDernImg

Cela te donne un code comme ceci :
Sub AppelFonction()
ActiveSheet.Shapes("Picture 3").Top = HauteurImgDansFeuil
End Sub


Function HauteurImgDansFeuil()
Dim Obj As Shape
Dim TopDernImg As Long, heightDernImg As Integer, TempTop As Long

For Each Obj In Sheets("Feuil1").Shapes 'A ADAPTER nom de la feuille
    If Obj.Type = msoPicture Then
        TempTop = Obj.Top
        If TempTop > TopDernImg Then 
            TopDernImg = TempTop
            heightDernImg = CInt(Obj.Height)
        End If
    End If
Next Obj
HauteurImgDansFeuil = TopDernImg + heightDernImg + 3 '3 = marge d'arrondi
End Function

Cordialement,
Franck P

pijaku · Answer

Essaie ceci :
Sub essai()
Sheets("Feuil1").Select
Range("C3:L23").Copy
Sheets("Feuil3").Select
Range("A65536").End(xlUp).Offset(0, 1) = "a" 'UTILITE????????
ActiveSheet.Pictures.Paste.Select
With Selection
    .Top = HauteurImgDansFeuil("Feuil3") 'ICI ADAPTE le nom de la feuille
    .Left = 30 'règle la marge de gauche
End With
Sheets("Feuil1").Select
Application.CutCopyMode = False
End Sub

Function HauteurImgDansFeuil(Feuille As String)
Dim Obj As Shape
Dim TopDernImg As Long, heightDernImg As Integer, TempTop As Long

For Each Obj In Sheets(Feuille).Shapes
    If Obj.Type = msoPicture Then
        TempTop = Obj.Top
        If TempTop > TopDernImg Then
            TopDernImg = TempTop
            heightDernImg = CInt(Obj.Height)
        End If
    End If
Next Obj
HauteurImgDansFeuil = TopDernImg + heightDernImg + 3 '3 = marge d'arrondi
End Function

Macro copier/coller sous forme d'image

2 réponses

Discussions similaires

Newsletters