Copy variable name picture from workbook with a variable name to cell in another workbook

[CJG19]

Good Morning,

I wonder if anyone would be kind enough to help.

I have a macro in workbook 'GRFT Macro Working Sheet.xlsm' that opens a macro enabled workbook you select from windows explorer. This workbook will always have a filename beginning 'GRFT D'. It then copies all of the information from the 'Summary' tab in the 'GRFT D' workbook (which is macro enabled) to 'GRFT Macro Working Sheet.xlsm', hides columns we need hidden and prints to PDF.

The only thing it won't copy is the picture, the picture is a signature related to a signature data validation list on a tab named 'Signature'. The signatures seem to be embedded somehow into the cells and the cell called a name e.g. Clare_Grew or Gemma_Jones depending on who has produced the GRFT.

When the name is selected in cell L2 on the summary sheet in 'GRFT D' it automatically picks the correct signature and puts it into cell I2 on the summary sheet. I need to copy this signature across, but with a variable picture name and a variable workbook name I am unsure of how to proceed.

Sub GRFT_Select()


'
' GRFT_Select Macro
'

'
Dim FD As FileDialog
Dim WBName As String
Dim WB As Workbook
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
    .Title = "Select the WorkBook that you want to open."
    .Filters.Clear
    .Filters.Add "Excel Workbooks", "*.xlsm"
    .AllowMultiSelect = False
    If .Show = -1 Then
        WBName = .SelectedItems(1)
    Else
        MsgBox "You did not select a Workbook."
        Exit Sub
    End If
End With
Set WB = Workbooks.Open(WBName)
With WB
    Worksheets("Summary").Activate
    Range("A1:AJ1000").Copy
    Workbooks("GRFT Macro Working Sheet.xlsm").Activate
    Range("A1:AJ1000").PasteSpecial
    Range("A:A").EntireColumn.Hidden = True
    Range("G:G").EntireColumn.Hidden = True
    Range("O:Q").EntireColumn.Hidden = True
    Range("V:V").EntireColumn.Hidden = True
    Range("AC:AD").EntireColumn.Hidden = True
    Range("AJ:AJ").EntireColumn.Hidden = True
   End With
 With ActiveSheet.PageSetup
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .Orientation = xlLandscape
        Dim i As Integer, PDFindex As Integer
    Dim PDFfileName As String
    
    With ActiveWorkbook
        PDFfileName = .Worksheets(1).Range("B4").Value & .Worksheets(1).Range("B5").Value & ".pdf"
    End With
    
    With Application.FileDialog(msoFileDialogSaveAs)
            
        PDFindex = 0
        For i = 1 To .Filters.Count
            If InStr(VBA.UCase(.Filters(i).Description), "PDF") > 0 Then PDFindex = i
        Next

        .Title = "Save workbook as PDF"
        .InitialFileName = PDFfileName
        .FilterIndex = PDFindex
        
        If .Show Then
            ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1), _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        End If
    
    End With
    End With
 
End Sub

Any help would be appreciated.

Many Thanks

CJG19

 

[OaklandJim]

I hope that this helps you do the copy and paste. It is a sub that copies a picture named SignaturePicture in Sheet1 and pastes it into the target cell in Sheet2.

Sub CopyPasteSignaturePicture()

'   Copy of the picture.
    Dim oNewPicture As Picture
    
'   Worksheet where the original picture is located.
    Dim wsSource As Worksheet

'   Worksheet where new picture is located.
    Dim wsTarget As Worksheet
    
'   Cell where new picture will be located.
    Dim rTargetCell As Range
    
'   Set ws objects to source and target worksheets.
    Set wsSource = ThisWorkbook.Worksheets(1)
    Set wsTarget = ThisWorkbook.Worksheets(2)
    
'   Specify where the copied picture will be located (which cell).
    Set rTargetCell = wsTarget.Cells(2, 5)
    
    wsSource.Pictures("SignaturePicture").Copy
    
    Set oNewPicture = wsTarget.Pictures.Paste

    With oNewPicture
        .Left = rTargetCell.Left
        .Top = rTargetCell.Top
        With .ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorBackground1
            .ForeColor.TintAndShade = 0
            .ForeColor.Brightness = 0
            .Transparency = 0
            .Solid
        End With
    End With

End Sub

 

[CJG19]

Thanks OaklandJim