Copier un image vers un autre feuille

[guy72]

Bonjour,

J'ai ce code qui me permets de copier les cellules de "O5 à AA5 de la feuille WS2300" à la feuille "Janvier" dans les cellules AF à AR, là je n'ai pas de problème.

Mais maintenant, il y a une image dans cellule Q5 et cette image ne ce copie pas dans la feuille "Janvier" en cellule AH

Sub WS_2300()

Dim FeWS230 As Worksheet
Dim FeJanvier As Worksheet
Dim Source As Range
Dim Colonne As String

Set FeWS2300 = Worksheets("WS2300")
Set FeJanvier = Worksheets("Janvier")

With FeWS2300

'Vent
Set Source = .Range("O5:AA5"): Colonne = "AF"
FeJanvier.Range(Colonne & 65535).End(xlUp).Offset(2, 0). _
Resize(Source.Rows.Count, Source.Columns.Count).Value = Source.Value

Sheets("Janvier").Select
End With
End Sub

En bref, je ne souhaite plus copier la valeur de la cellule Q5, mais l'image qui est à sa place.

Avec un copier/coller, ça fonctionne que suer la même feuille, mais avec VBA, je n'y arrive pas.

Fiichier : Cijoint.fr - Service gratuit de dépôt de fichiers

Merci de votre aide

Cordialement

Guy


--------------------------------------------------------------------------------

 

[PMO2]

Re : Copier un image vers un autre feuille

Bonjour,

Une piste avec le code suivant

Sub pmo()
Dim S As Worksheet
Dim S2 As Worksheet
Dim SH As Shape
Dim R As Range
Set S = Sheets("WS2300")
Set S2 = Sheets("Janvier")
For Each SH In S.Shapes
  Set R = SH.TopLeftCell
  If Not Application.Intersect(R, S.Range("Q4:Q6")) Is Nothing Then
    SH.Copy
    S2.Select
    S2.Range("AH11").Select
    S2.PasteSpecial Format:="Image (PNG)", Link:=False, DisplayAsIcon:=False
    Exit For
  End If
Next SH
End Sub

Cordialement.

PMO
Patrick Morange

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour,
Ça me convient à 90%.
Dans la cellule AH11, l'image se place en haut à gauche ("TopLeftCell" peut-être?).
Je souhaiterais qu'elle se positionne En plein centre de la cellule AH11.
J'ai essayé "Center" ou "CenterCenter" mais ça ne fonctionne pas.
Que faut-il faire ?
Cordialement
Guy

 

[Robert]

Re : Copier un image vers un autre feuille

Bonsoir le fil, bonsoir le forum,

Guy, deux fils pour le même problème (ici et ce fil) et en plus tu nous plantes José et moi qui attendions ton fichier pour essayer de te donner une réponse... Pas très étique tout ça. Jette donc un coup d'œil à la charte...

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour,
Désolé Robert, j'ai complètement oublié que j'avais posé le même sujet.
La charte, pas de problème, mais je pense qu'elle peut comprendre que l'on peut faire une erreur.
Encore désolé
Cordialement
Guy

 

[PMO2]

Re : Copier un image vers un autre feuille

Bonjour,

Essayez

Sub pmo()
Dim S As Worksheet
Dim S2 As Worksheet
Dim SH As Shape
Dim R As Range
Set S = Sheets("WS2300")
Set S2 = Sheets("Janvier")
For Each SH In S.Shapes
  Set R = SH.TopLeftCell
  If Not Application.Intersect(R, S.Range("Q4:Q6")) Is Nothing Then
    SH.Copy
    S2.Select
    S2.Range("AH11").Select
    S2.PasteSpecial Format:="Image (PNG)", Link:=False, DisplayAsIcon:=False
    Selection.ShapeRange.IncrementLeft 7.5  '/// ajout
    Exit For
  End If
Next SH
End Sub

Cordialement.

PMO
Patrick Morange

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour,
Ok ça roule pour moi.
J'ai juste réglé à 3.5 pour ajuster et j'ai ajouté :
Selection.ShapeRange.IncrementTop 1.5.
Merci de ton aide.
Et pour Robert, c'est vrais j'ai me.... 🙁(((
Cordialement
Guy

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour,
Excusez, j'ai répondu trop vite.
Le code me conviens, mais comme dans le fichier, je pensais : qu'au 2ème clic l'image se mettrait en AH13, au 3ème clic l'image se mettrait en AH15 etc....avec une ligne entre chaque comme :

Set Source = .Range("O5:AA5"): Colonne = "AF"
FeJanvier.Range(Colonne & 65535).End(xlUp).Offset(2, 0). _
Resize(Source.Rows.Count, Source.Columns.Count).Value = Source.Value

J'ai essayé de l'intégrer de plusieurs façon, mais je ne trouve pas.

Ou si c'est pas possible, une macro à part qui fasse la même chose que pour l'image (l'image s'appelle toujours "Image 19")

Cordialement
Guy

PS : Ne pas tenir compte du code de la feuille "Janvier" il est à supprimer.

 

[PMO2]

Re : Copier un image vers un autre feuille

Bonjour,

qu'au 2ème clic l'image se mettrait en AH13, au 3ème clic l'image se mettrait en AH1

Essayez le code suivant

Const CELLULE_BASE As String = "AH11"

Sub pmo_2()
Dim S As Worksheet
Dim S2 As Worksheet
Dim SH As Shape
Dim SH2 As Shape
Dim R As Range
Dim R2 As Range
Dim bool As Boolean
Set S = Sheets("WS2300")
Set S2 = Sheets("Janvier")
For Each SH In S.Shapes
  Set R = SH.TopLeftCell
  If Not Application.Intersect(R, S.Range("Q4:Q6")) Is Nothing Then
    SH.Copy
    S2.Select
    Set R2 = S2.Range(CELLULE_BASE)
    For Each SH2 In S2.Shapes
      Do Until SH2.TopLeftCell.Address <> R2.Address
        Set R2 = R2.Offset(2, 0)
      Loop
    Next SH2
    R2.Select
    S2.PasteSpecial Format:="Image (PNG)", Link:=False, DisplayAsIcon:=False
    Selection.ShapeRange.IncrementLeft 3.5
    Selection.ShapeRange.IncrementTop 1.5
    R2.Select
    Exit For
  End If
Next SH
End Sub

Cordialement.

PMO
Patrick Morange

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour,
Ok, c'est ça.
Merci de ton aide

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour Patrick,
Excuse-moi, je reviens, quand je copie la flèche (à part au nord) elle n’est plus centrer avec les autres points cardinaux.
Est-il possible d’arriver à la centrer quel que soit l’angle ?
Merci de ton aide
Cordialement
Guy

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour,
Je viens de voir que, effectivement la flèche ne peut pas être centrée avec les lignes :
Selection.ShapeRange.IncrementLeft 10
Selection.ShapeRange.IncrementTop 2

Je suppose que c'est là qu'il faut changer quelque chose , mais quoi ?

Merci de ton aide
Cordialement

 

[PMO2]

Re : Copier un image vers un autre feuille

Bonjour,

Essayez avec ce code

Const CELLULE_BASE As String = "AL11"

Sub pmo_3()
Dim S As Worksheet
Dim S2 As Worksheet
Dim SH As Shape
Dim SH2 As Shape
Dim SH3 As Shape
Dim R As Range
Dim R2 As Range
Set S = Sheets("WS2300")
Set S2 = Sheets("Janvier")
For Each SH In S.Shapes
  Set R = SH.TopLeftCell
  If Not Application.Intersect(R, S.Range("U4:U6")) Is Nothing Then
    SH.Copy
    S2.Select
    Set R2 = S2.Range(CELLULE_BASE)
    For Each SH2 In S2.Shapes
      Do Until SH2.TopLeftCell.Address <> R2.Address
        Set R2 = R2.Offset(2, 0)
      Loop
    Next SH2
    R2.Select
    S2.PasteSpecial Format:="Image (PNG)", Link:=False, DisplayAsIcon:=False
    Set SH3 = S2.Shapes(S2.Shapes.Count)
    If SH3.Width < R2.Width Then
      SH3.Left = SH3.Left + (R2.Width - SH3.Width) / 2
    End If
    If SH3.Height < R2.Height Then
      SH3.Top = SH3.Top + (R2.Height - SH3.Height) / 2
    End If
    R2.Select
    Exit For
  End If
Next SH
End Sub

Cordialement.

PMO
Patrick Morange

 

[guy72]

Re : Copier un image vers un autre feuille

Bonjour Patrick
Merci pour le changement, c'est parfait.
Merci de ton aide
Cordialement
Guy