Export to xlsx with only visible cells included image

Viewed 41

I have a master excel file. I want to export only visible cells to new .xlsx file as the sign-off document for engineers. Also, all formulas have to be converted to values. I manage to export everything except the image. The image doesn't export for some reason which is the company logo. I need your help with this. I looked all over the internet and I tried myself but it didn't work. Please see the code below.

Sub Click_Export_PS_To_XLSX1()

Call TurnOffStuff

Dim MyFileName As String
Dim ws As Worksheet
Dim shNewName As String
Dim myXLSXFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim rngToSave As Range
Dim ShapeCopy As Shape
Dim ShapePaste As Shape
Dim txtTest As String

    Set ws = Worksheets(tblPS_Name)
    Set tblPS = ws.ListObjects(tblPS_Name)
    Set tblPS = Range(tblPS).ListObject

    tblPS_FR = tblPS.DataBodyRange.Rows.Count + 18
    
    MyFileName = ws.Range("B5") & " - Sign Off"
    shNewName = Right(Cells(2, 1).Value, 3) & " - Cable Schedule"
        
        Application.DisplayAlerts = False
    On Error GoTo err
     Set myWB = ThisWorkbook
    txtTest = Environ("UserProfile")
    
    myXLSXFileName = txtTest & MyFileName & ".xlsx"

    Set ShapeCopy = ws.Shapes("Picture 1")
    ShapeCopy.Copy
        
    Call Click_PlotView_PS_Full_View
        
    Set rngToSave = Range("A1", Cells(tblPS_FR + 18, tblPS_.ECPrint))
        rngToSave.SpecialCells(xlCellTypeVisible).Copy
     
     
    Set tempWB = Application.Workbooks.Add(1)
    With tempWB
        .Sheets(1).Range("A1").PasteSpecial xlPasteFormats
        .Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
        .Sheets(1).Range("A1").Select
            With ActiveWindow
                .SplitColumn = 0
                .SplitRow = 1
            End With
        ActiveWindow.FreezePanes = True
        .Sheets(1).Range("1:2,16:16").RowHeight = 30
        .Sheets(1).Range("A17").RowHeight = 7.5
        .Sheets(1).Name = shNewName
        .Sheets(1).Range("A17", Cells(tblPS_FR + 17, tblPS_.ECPrint - 5)).AutoFilter
        .SaveAs FileName:=Environ("UserProfile") & myXLSXFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        .Close
    End With

err:
    
    Application.DisplayAlerts = True

    Call TurnOnStuff

End Sub

This is a very useful exercise for making the sign-off the document.

Thank you so much.

0 Answers
Related