Microsoft 365 choisir une page

[Keiko]

Bonjour à tous,

j'ai trouvé un code qui marche super bien et qui download une photo dans excel à l'endroit que l'on souhaite.
Mais je voudrais qui download la photo sur une autre page.

Pour le moment, il imprime la

Range("o1:s11").Select 'emplacement des cellules fusionnées ou la photo sera affiché

Mais je voudrais qu'il affiche sur la page DP au même endroit.

Voici le code en entier pour ceux qui veulent en profiter

Bonne journée !

Sub Downloadcharpente()

'DEPROTECTION
ActiveSheet.Unprotect ""

'SUPPRIMER LA DERNIERE PHOTO CREE
If Range("h43") <> "" Then
PHOTO1 = Range("h43").Value
ActiveSheet.Shapes(PHOTO1).Delete
End If

'SELECTIONER LES CELLULES FUSIONNEES
Range("o1:s11").Select 'emplacement des cellules fusionnées ou la photo sera affiché
Ad = Selection.Address
CellH = Selection.Height
CellW = Selection.Width

'EXTRACTION DE L'IMAGE

On Error Resume Next
Application.ScreenUpdating = False

IMPORTATION = Application.GetOpenFilename("Toutes les images (*.jpg;*.bmp;*.tiff;*.tif;*.gif;*.jpeg;*.png;*.jpe;*.jfif),*.jpg;*.bmp;*.tif;*.tiff;*.gif;*.jpeg;*.png;*.jpe;*.jfif", , "Choisissez l'image") ' choix nom du fichier
If IMPORTATION = "Faux" Then
MsgBox "Operation annulée" & vbCrLf & "Attention, veuillez renouveler l'action !", vbExclamation
'SUPRESSION DU NOM DE L'IMAGE PRECEDENTE
Range("h43").Select
Selection.ClearContents
'SELECTIONER UNE CELLULE
[h42].Select
'PROTECTION
ActiveSheet.Protect "Jpc42*"
Exit Sub
End If

'----- [ B]
ActiveSheet.Pictures.Insert(IMPORTATION).Select
'-------------[ /B] ' insertion
With Selection.ShapeRange
MemW = .Width: MemH = .Height
'adapte les ratio
If MemH < CellH And MemW < CellW Then
'l'image < cellule
RatioHz = MemH / CellH
RatioVt = MemW / CellW
If RatioVt < RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (CellW / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW > CellW Then
'l'image > cellule
RatioHz = CellH / MemH
RatioVt = CellW / MemW
If RatioVt > RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW < CellW Then
'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
ElseIf MemH < CellH And MemW > CellW Then
'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
Else
Stop ' pas prévu ?
End If

.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = Range(Ad).Top + T ' haut de la cellule
.Left = Range(Ad).Left + L ' gauche de la cellule
.Height = HT
.Width = Lg ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With



'ENREGISTRER LE NOM DE L'IMAGE DANS LA CELLULE A GAUCHE
PHOTO2 = Selection.ShapeRange.Name
Range("h43").Value = PHOTO2

'SELECTIONER UNE CELLULE
[h42].Select

'PROTECTION
'ActiveSheet.Protect ""

End Sub

 

[patricktoulon]

re
bonjour
je regarde pas plus le code mais si tu veux appliquer a une autre feuille n'utilise pas activesheet
ou un range sans parent dans ton code

Range("o1:s11") ---> NON!!!!
sheets("toto").Range("o1:s11") ----> OUI!!!

 

[Keiko]

Ca ne marche pas :'(

 

[xUpsilon]

Bonjour,

Patrick te donnait là un exemple, si tu as simplement recopié "Sheets("toto")" forcément ça va pas fonctionner.
Il faut entrer Sheets("DP") ici si j'ai bien compris.

Bonne continuation

 

[Keiko]

Malheureusement ca ne marche pas...
Quelqu'un peut reprendre le code? :'(

 

[Keiko]

Voila ce qu'il fallait faire

'DEPROTECTION
ActiveSheet.Unprotect ""

'SUPPRIMER LA DERNIERE PHOTO CREE
If Range("g43") <> "" Then
PHOTO1 = Range("g43").Value
ActiveSheet.Shapes(PHOTO1).Delete
End If

'SELECTIONER LES CELLULES FUSIONNEES
Sheets("DP").Select
Range("u20:y40").Select 'emplacement des cellules fusionnées ou la photo sera affiché
Ad = Selection.Address
CellH = Selection.Height
CellW = Selection.Width

'EXTRACTION DE L'IMAGE

On Error Resume Next
Application.ScreenUpdating = False

IMPORTATION = Application.GetOpenFilename("Toutes les images (*.jpg;*.bmp;*.tiff;*.tif;*.gif;*.jpeg;*.png;*.jpe;*.jfif),*.jpg;*.bmp;*.tif;*.tiff;*.gif;*.jpeg;*.png;*.jpe;*.jfif", , "Choisissez l'image") ' choix nom du fichier
If IMPORTATION = "Faux" Then
MsgBox "Operation annulée" & vbCrLf & "Attention, veuillez renouveler l'action !", vbExclamation
'SUPRESSION DU NOM DE L'IMAGE PRECEDENTE
Range("g43").Select
Selection.ClearContents
'SELECTIONER UNE CELLULE
[i43].Select
'PROTECTION
ActiveSheet.Protect "Jpc42*"
Exit Sub
End If

'----- [ B]
ActiveSheet.Pictures.Insert(IMPORTATION).Select
'-------------[ /B] ' insertion
With Selection.ShapeRange
MemW = .Width: MemH = .Height
'adapte les ratio
If MemH < CellH And MemW < CellW Then
'l'image < cellule
RatioHz = MemH / CellH
RatioVt = MemW / CellW
If RatioVt < RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (CellW / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW > CellW Then
'l'image > cellule
RatioHz = CellH / MemH
RatioVt = CellW / MemW
If RatioVt > RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW < CellW Then
'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
ElseIf MemH < CellH And MemW > CellW Then
'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
Else
Stop ' pas prévu ?
End If

.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = Range(Ad).Top + T ' haut de la cellule
.Left = Range(Ad).Left + L ' gauche de la cellule
.Height = HT
.Width = Lg ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With



'ENREGISTRER LE NOM DE L'IMAGE DANS LA CELLULE A GAUCHE
PHOTO2 = Selection.ShapeRange.Name
Range("g43").Value = PHOTO2

'SELECTIONER UNE CELLULE
[i43].Select

'PROTECTION
'ActiveSheet.Protect ""

Sheets("L").Select

 

[xUpsilon]

Re,

Si tu veux que ton code soit lisible, utilise les balises CODE=vb /CODE stp
Aussi, si j'ai bien vu ta modification, tu as simplement ajouté un sheets("DP").Select, ce qui est assez lourd et encombrant. Navré te le répéter mais écrire Worksheets("DP").Range("___") ou Range("DP!___") aurait été bien plus léger et fonctionne forcément, à moi que tu ne l'aies pas écrit correctement.

Bonne continuation