Copier slide nom fichier variable

bonjour,

je souhaiterai modifier cette macro en me passant de la boite de dialogue.

en effet je souhaite que le slide soit importé du ppt présent dans le dossier actif et soit choisi en fonction du nom de l'onglet actif.

pour être clair si l'onglet actif contient janvier on copie le slide dans le ppt qui contient le mot Janvier (fonction like ?)

Possible ?

merci d'avance

Sub Importation_diapos()
'coché la case dans: Outils>références> Microsoft Powerpoint 16.0 Object Library
    Dim nom_fichier As String, fichier As Object
    Dim ppt_pres As PowerPoint.Presentation, diapo As PowerPoint.Slide

    'Affiche la boîte de dialogue "Ouvrir"
    nom_fichier = Application.GetOpenFilename("fichiers PowerPoint *.ppt*,")

    'Sortie si annulation
    If nom_fichier = "Faux" Or nom_fichier = Empty Then MsgBox "aucun fichier sélectionné": Exit Sub

    'Assigne le fichier ouvert et vérifie que c'est une présentation PowerPoint
    Set fichier = GetObject(nom_fichier)
    If Not fichier.Application.Name Like "*PowerPoint" Then MsgBox "fichier ouvert non PowerPoint": fichier.Close: Exit Sub
    Set ppt_pres = fichier

        ppt_pres.Slides(1).Copy
       ActiveSheet.Paste

    ppt_pres.Application.Quit

End Sub

Bonjour,

A tester :

Option Explicit

Sub TestImportation_diapos()
    Importation_diapos "Janvier", ActiveSheet
End Sub

Sub Importation_diapos(ByVal NomATrouver As String, ByVal ShDestination As Worksheet)

Dim Continuer As Boolean
Dim I As Integer, J As Integer
Dim PptApp As PowerPoint.Application
Dim Ppt_Pres As PowerPoint.Presentation

    Set PptApp = GetObject(, "PowerPoint.Application")
    If PptApp.Presentations.Count > 0 Then
       Set Ppt_Pres = PptApp.ActivePresentation
       With Ppt_Pres
            For I = 1 To .Slides.Count
                Continuer = True
                With .Slides(I)
                    If .Shapes.Count > 0 Then
                       For J = 1 To .Shapes.Count
                           With .Shapes(J)
                                If .HasTextFrame Then
                                    If InStr(1, .TextFrame2.TextRange, NomATrouver, vbTextCompare) > 0 Then
                                       Ppt_Pres.Slides(I).Copy
                                       ShDestination.Paste
                                       Continuer = False
                                    End If
                                End If

                           End With

                       Next J
                    End If
                End With
                If Continuer = False Then Exit For
            Next I
       End With
    End If
  '  Ppt_Pres.Close
  '  PptApp.Quit

    Set Ppt_Pres = Nothing: Set PptApp = Nothing

End Sub

bonjour et merci pour ton aide, un problème :

La référence PowerPoint est cochée ?

PointPoint est ouvert ?

oui Eric la référence est cochée, mais powerpoint fermé.

Il faut que PowerPoint soit ouvert. Cela pose-t-il un problème ?

c'est mieux si on peut ouvrir et fermer l'appli.

et avec appli ouverte , cela n'importe pas alors que le nom correspond entre l'onglet et le ppt

Tu n'as pas bien vu le fonctionnement de mon code. On recherche le mot dans un shape d'un des slides.

ok Eric ,merci effectivement cela fonctionne je n'avais pas vu la solution, mais j'était parti sur la correspondance nom onglet et nom du powerpoint et importer la diapo numéro 3 par exemple.

La piste est intéressante et je vais garder précieusement ton code, mais serait ce possible comme initialement demandé?

merci

nb , c'est sans doute mon manque de clareté dans la demande , sorry..

C'est cela que tu demandes ?

Sub TestImportation_diapos()
    Importation_diapos ActiveSheet.Name, ActiveSheet
End Sub

en fait , dans le dossier actif il y a plusieurs ppt.

Exemple si on clique sur le bouton de la macro

Si on est sur l'onglet Janvier du fichier excel => on ouvre le fichier "rapport XXX de Janvier.ppt" du dossier actif car ce .ppt contient le nom de l'onglet.

et on copie le 3 eme slide de cette présentation sur l'onglet excel.

J'espère être clair et si ce n'est pas le cas j'en suis désolé...

A tester :

Option Explicit

Sub LancerImportation_diapo()

Dim NomPpt As String
Dim Chemin As String

    NomPpt = PptChoisi(ActiveSheet.Name)
    If NomPpt <> "" Then
       Chemin = ActiveWorkbook.Path & "\" & NomPpt
       Importation_diapo2 Chemin, 3, ActiveSheet
    End If

End Sub

Sub Importation_diapo2(ByVal CheminPpt2 As String, ByVal NumeroSlide As Integer, ByVal ShDestination As Worksheet)

Dim PptApp As PowerPoint.Application
Dim Ppt_Pres As PowerPoint.Presentation

    Set PptApp = CreateObject("PowerPoint.Application")

    With PptApp
         .Visible = msoCTrue
         Set Ppt_Pres = .Presentations.Open(CheminPpt2)
    End With

    Ppt_Pres.Slides(NumeroSlide).Copy
    ShDestination.Paste

    Ppt_Pres.Close
    PptApp.Quit

    Set Ppt_Pres = Nothing: Set PptApp = Nothing

End Sub

Function PptChoisi(ByVal ChaineDansPpt As String) As String

Dim Fso As Object, Dossier_Racine As Object, Fichier As Object, Fichiers As Object

    PptChoisi = ""
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier_Racine = Fso.getfolder(ActiveWorkbook.Path & "\")
    Set Fichiers = Dossier_Racine.Files

    For Each Fichier In Fichiers
        Select Case Fso.GetExtensionName(Fichier)
               Case Is = "pptx", "pptm"
                    If InStr(1, LCase(Fichier.Name), LCase(ChaineDansPpt), vbTextCompare) > 0 Then
                       PptChoisi = Fichier.Name
                       Exit For
                    End If
        End Select
    Next Fichier

    Set Fichiers = Nothing: Set Dossier_Racine = Nothing: Set Fso = Nothing

End Function

désolé de la réponse tardive, c'est parfait.

Merci Eric !